c***************************** file: mg1.f *****************************
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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(5) :: nptr
            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
        ip(18)=min(9,ip(18))
        ip(18)=max(1,ip(18))
        if(ip(5)<0.or.ip(5)>ip(18)) ip(5)=1
        if(ip(6)<-5.or.ip(6)>5) ip(6)=1
        if(ip(9)<-1.or.ip(9)>1) ip(9)=0
        if(ip(12)/=1) ip(12)=0
        if(ip(13)<1.or.ip(13)>10) ip(13)=1
        if(abs(ip(6))/=4) ip(13)=1
        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(ip)
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,ibs,ibp,itdof,nptr)
        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,nptr,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==6) 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.or.iprob==5) 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 12.0 - - - june, 2016
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==1) then
            if(ip(7)/=9) ip(7)=0
            rp(63)=0.0e0_rknd
        else if(iprob==2) then
            rp(63)=rp(3)
        else 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==4) then
            if(ip(7)/=8) ip(7)=0
            rp(63)=rp(3)
        else if(iprob==5) then
            rp(63)=rp(3)
        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 12.0 - - - june, 2016
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,vxsv,vysv,da,dg
            real(kind=rknd), dimension(200) :: 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)
        nrl=ip(13)
        itask=ip(7)
        iprob=abs(ip(6))
        ising=ip(12)
        nproc=ip(49)
        nb=ip(91)
        maxd=ip(85)
        ndd=ip(33)
c
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        epsmg=max(1.0e-4_rknd,eps)
        if(iprob==4) then
            do i=1,nrl
                t(i)=rp(90+i)
            enddo
            call pl2ip(t,nrl)
            do i=1,nrl
                rp(90+i)=t(i)/real(nproc,rknd)
            enddo
        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)<ipath(1,nproc+2)) then
            ip(25)=72
        else
            ip(25)=0
        endif
        call timer(35_iknd)
        call exflag(ip(25))
        call timer(11_iknd)
        if(ip(25)/=0) return
c
c       initialize for domain decomposition
c
        rp(52)=1.0e0_rknd
        rp(56)=1.0e0_rknd
        rp(57)=1.0e0_rknd
        rp(54)=0.0e0_rknd
c*      if(iprob==2) rp(63)=rp(3)
c*      if(iprob==4) rp(63)=rp(3)
c*      if(iprob==5) rp(63)=rp(3)
        mxdamp=10
        ievals=1
        itype=0
        iconv=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(4)
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      vxsv(isize(39)),vysv(isize(39)),
     6      jua(isize(11)),ua(isize(12)),da(isize(25)),
     7      jug(isize(13)),ug(isize(14)),dg(isize(26)),
     8      juac(isize(22)),uac(isize(23)),ugc(isize(24)),
     9      jugc(isize(24)),jbo(isize(21)))
        allocate(ir0(2*isize(46)),map(isize(46)),ja0(isize(41)),
     +      a0(isize(42)),h0(isize(43)),g0(isize(44)),
     1      su0(isize(45)),sm0(isize(45)))
c
        call timer(35_iknd)
        lenja0=ip(99)
        call setgr2(ip,itnode,itdof,ir0,ja0,lenja0,kflag)
        call timer(20_iknd)
        if(kflag/=0) stop 9011
        call pthmap(ip,lipath,map,ipath,ir0)
c
        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)
        if(iprob==4) call bdinit(ntf,ndf,ip,rp,u,vx,vy,sf,
     +      itdof,itnode,ibndry,ibedge,bdlwr,bdupr,gdxy,sxy)
c
c       first matrix and right hand side
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)
        call timer(29_iknd)
c
c       compute ordering symbolic factorization
c
        maxjua=isize(11)
        maxua=isize(12)
        maxjuac=isize(22)
        maxuac=isize(23)
        if(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
        else
            call timer(35_iknd)
            call sfhb(nb,ja,jp,ibs,ibo,a,da,maxjuac,
     +          juac,maxuac,uac,ispd,dtol,1_iknd,method)
            call timer(23_iknd)
            ip(100)=juac(nb+1)-1
        endif
c
        if(iprob==5) then
            maxjug=isize(13)
            maxug=isize(14)
            if(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/=1) then
                do i=1,nb
                    jbo(i)=abs(ibo(i))
                enddo
                call timer(35_iknd)
                call sfhb(nb,ja,jp,ibs,ibo,g,dg,maxjugc,
     +              jugc,maxugc,ugc,1_iknd,dtol,1_iknd,method)
                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(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)
                else
                    call timer(35_iknd)
                    call sfhb(nb,ja,jp,ibs,ibo,a,da,maxjuac,
     +                  juac,maxuac,uac,ispd,dtol,0_iknd,method)
                    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,da,jua,ua,juac,jp,uac,
     1              b,rd,p,udot,u0dot,epsmg,jflag,1_iknd)
                call timer(25_iknd)
                if(iconv==1) go to 170
                if(itnum>mxnwtt) go to 100
            else if(iprob==4) then
                maxs=ndf+ndd
                call blk4(ndf,nrl,ip,du,dum,duc,ja,ibs,ibp,ibo,a,
     +              da,jua,ua,juac,jp,uac,h,g,maxs,su,b,p,dl,rd,
     1              maxd,udot,epsmg,jflag,1_iknd)
                call timer(19_iknd)
            else if(iprob==5) then
                if(itnum>1) then
                    if(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)
                    else
                        call timer(35_iknd)
                        call sfhb(nb,ja,jp,ibs,ibo,g,dg,maxjugc,
     +                      jugc,maxugc,ugc,1_iknd,dtol,0_iknd,method)
                        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,da,dg,
     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,da,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,da,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,vxsv,vysv,itnode,ibndry,ibedge,
     +          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,ndf,rp)
c****           iconv=jcvtst(itnum,-iprob,itask,itype,ndf,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,vxsv,vysv,itnode,ibndry,ibedge,
     +          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<mxdamp) go to 70
                ip(25)=2
                go to 190
            endif
c
c       convergence test
c
            call hist3(11_iknd,itnum,rp(56),rp(54))
            iconv=icvtst(itnum,-iprob,itask,itype,ndf,rp)
c****       iconv=jcvtst(itnum,-iprob,itask,itype,ndf,rp)
            if(iprob/=3.and.iconv==1) go to 170
c
c       adjust interior mesh in shape optimization problem
c
            if(itask==8) then
                call timer(35_iknd)
                call mfe2a(ntf,nvf,nbf,ip,rp,itnode,ibndry,itdof,u,
     +              vx,vy,sf,sxy,0_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)
            endif
c
        enddo
c
  100   itnum=jnwtt
        if(iconv==-1) go to 170
        ip(25)=11
c
c       newton iteration failed to converge...reset u, udot, and rp
c
  130   ip(79)=ievals
        ip(80)=itnum
        go to 190
c
c       newton iteration was successful
c
  170   ip(25)=0
        ip(79)=ievals
        ip(80)=itnum
        if(iprob==3) then
            ip(80)=itnum-1
            call updpth(-1_iknd,5_iknd,rp)
        else if(iprob/=1) then
            call updip(-1_iknd,4_iknd,rp,ip)
        endif
        call timer(35_iknd)
        call cdlfn(ndf,ip,itnode,itdof,udl,ja,ibs,ibp,ibo,
     +      a,da,jua,ua,juac,jp,uac)
        call timer(9_iknd)
c
  190   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,da,dg,
     1      jugc,jbo,ir0,map,ja0,a0,h0,g0,su0,sm0,vxsv,vysv)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pltmgp(ip,rp,vx,vy,sf,itnode,ibndry,u,u0,udot,
     +      u0dot,evr,evl,um,uc,vxgf,vygf,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,vxgf,vygf,udl
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), allocatable,  dimension(:) :: vx0,vy0
            character(len=80) :: iostr
            character(len=80), save :: msg
cy
            external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy
            data msg/'pltmg:      tcur       deltat        utnorm'/
c
c       main routine for parabolic problems
c
        itask=ip(7)
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        ndf=ip(4)
        nrl=ip(13)
c
        allocate(vx0(nvf),vy0(nvf))
        call filutl(msg,0_iknd)
c
        call uinit(ntf,ndf,ip,rp,itnode,ibndry,ibedge,vx,vy,sf,
     +      u,um,uc,itdof,gdxy,sxy)
c
        if(itask==10) then
            tstart=rp(28)
            tend=rp(29)
            if(tstart>=tend) go to 100
            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
                call gf2nd(ntf,nvf,nbf,nrl,rp(21),itnode,ibndry,
     +              itdof,sf,vx0,vy0,vxgf,vygf,1_iknd,sxy)
                idsp=0
            endif
            if(ifirst==-1) then
                rp(46)=tnew
                rp(28)=tnew
                rp(29)=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) go to 100
            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(idsp<mxfail) then
                    rp(47)=rp(47)/2.0e0_rknd
                    go to 220
                else
                    do i=1,ndf
                        u(i)=u0(i)
                    enddo
                    write(unit=iostr,fmt='(2i3,3(1x,e12.5))')
     +                  ip(25),itflag,rp(46),rp(47),rp(50)
                    call filutl(iostr,0_iknd)
                    go to 100
                endif
            else
                tnew=rp(46)+rp(47)
                if(itflag==2.and.idsp==1) ifirst=-1
                if(itflag==-4.and.idsp==1) ifirst=-1
                go to 60
            endif
        else
            tcur=rp(46)
            deltat=max(rp(47),rp(48))
            rp(21)=tcur
            if(deltat>0) then
                rp(45)=1.0e0_rknd/deltat
            else
                rp(45)=0.0e0_rknd
                go to 100
            endif
            call gf2nd(ntf,nvf,nbf,nrl,rp(21),itnode,ibndry,
     +          itdof,sf,vx0,vy0,vxgf,vygf,0_iknd,sxy)
            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
  100   deallocate(vx0,vy0)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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)<abs(rp(71))) then
                    rp(71)=sigma*(1.0e0_rknd+eps)
                    go to 20
                else
                    rp(1)=rp(31)
                    rp(2)=rp(32)
                    return
                endif
            endif
        enddo
   30   ip(7)=0
c
c       fixup tangent for the case of bifurcation
c
        dnorm=rl2nrm(ndf,udot)*rl2nrm(ndf,evr)
        if(dnorm>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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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
        rp(63)=rp(3)
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)
c
        if(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
        endif
        write(unit=iostr,fmt='(a11,e12.5,3x,a3,e12.5)')
     +      'pltmg: rho=',rp(22),'mu=',rp(63)
        call filutl(iostr,0_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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,vxsv,vysv,da,dg
cy
            external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy
c
c       approximate newton method
c
c*
c
c       uncomment for the active set approach code.
c
cc      rp(63)=0.0e0_rknd
cc      rp(3)=0.0e0_rknd
c*
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        ndf=ip(4)
        itask=ip(7)
        iprob=ip(6)
        ising=ip(12)
        nrl=ip(13)
        mpisw=ip(48)
        nproc=ip(49)
        nb=ip(91)
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        maxd=ip(85)
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(4)
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      vxsv(isize(39)),vysv(isize(39)),
     6      jua(isize(11)),ua(isize(12)),da(isize(25)),
     7      jug(isize(13)),ug(isize(14)),dg(isize(26)),
     8      juac(isize(22)),uac(isize(23)),ugc(isize(24)),
     9      jugc(isize(24)),jbo(isize(21)))
c
        if(iprob==3) then
            call evinit(ndf,ip,evl,evr,itdof,ibndry,ibedge)
        else
            call uinit(ntf,ndf,ip,rp,itnode,ibndry,ibedge,
     +          vx,vy,sf,u,um,uc,itdof,gdxy,sxy)
        endif
        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)
        if(iprob==4) call bdinit(ntf,ndf,ip,rp,u,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(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
        else
            call timer(35_iknd)
            call sfhb(nb,ja,jp,ibs,ibo,a,da,maxjuac,
     +          juac,maxuac,uac,ispd,dtol,1_iknd,method)
            call timer(23_iknd)
            ip(100)=juac(nb+1)-1
        endif
c
        if(iprob==5) then
            maxjug=isize(13)
            maxug=isize(14)
            if(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/=1) then
                do i=1,nb
                    jbo(i)=abs(ibo(i))
                enddo
                call timer(35_iknd)
                call sfhb(nb,ja,jp,ibs,ibo,g,dg,maxjugc,
     +              jugc,maxugc,ugc,1_iknd,dtol,1_iknd,method)
                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(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)
                else
                    call timer(35_iknd)
                    call sfhb(nb,ja,jp,ibs,ibo,a,da,maxjuac,
     +                  juac,maxuac,uac,ispd,dtol,0_iknd,method)
                    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,da,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,da,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) then
                maxs=ndf
                call blk4(ndf,nrl,ip,du,dum,duc,ja,ibs,ibp,ibo,a,
     +              da,jua,ua,juac,jp,uac,h,g,maxs,su,b,p,dl,rd,
     1              maxd,udot,epsmg,jflag,0_iknd)
                rp(72)=duc(1)
                call timer(19_iknd)
            else if(iprob==5) then
                if(itnum>1) then
                    if(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)
                    else
                        call timer(35_iknd)
                        call sfhb(nb,ja,jp,ibs,ibo,g,dg,maxjugc,
     +                      jugc,maxugc,ugc,1_iknd,dtol,0_iknd,method)
                        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,da,dg,
     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,da,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,da,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,vxsv,vysv,itnode,ibndry,ibedge,
     +          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,ndf,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,vxsv,vysv,itnode,ibndry,ibedge,
     +          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(iter<mxdamp) go to 70
                ip(25)=2
                if(jflag/=0) ip(25)=11
                go to 130
            endif
c
c       convergence test
c
            call hist3(11_iknd,itnum,rp(56),rp(54))
            iconv=icvtst(itnum,iprob,itask,itype,ndf,rp)
            if(iprob/=3.and.iconv==1) go to 170
c
c       adjust interior mesh in shape optimization problem
c
            if(itask==8) then
                call timer(35_iknd)
                call mfe2a(ntf,nvf,nbf,ip,rp,itnode,ibndry,itdof,u,
     +              vx,vy,sf,sxy,0_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)
            endif
c
        enddo
  100   itnum=jnwtt
        if(iconv==-1) go to 170
        ip(25)=11
c
c       newton iteration failed to converge...reset u, udot, and rp
c
  130   ip(79)=ievals
        ip(80)=itnum
        if(iprob==4) then
            do i=1,90
                rp(i)=rpsv(i)
            enddo
        else
            do i=1,100
                rp(i)=rpsv(i)
            enddo
        endif
        if(iprob==3) then
            do j=1,ndf
                udot(j)=u0dot(j)
                u(j)=u0(j)
            enddo
        else if(iprob==6) then
            do j=1,ndf
                u(j)=u0(j)
            enddo
        endif
        go to 190
c
c       newton iteration was successful
c
  170   ip(25)=0
        ip(79)=ievals
        ip(80)=itnum
        if(iprob==3) ip(80)=itnum-1
        if(mpisw==1.and.nproc>1) then
            call timer(35_iknd)
            call cdlfn(ndf,ip,itnode,itdof,udl,ja,ibs,ibp,ibo,
     +          a,da,jua,ua,juac,jp,uac)
            call timer(9_iknd)
        endif
c
  190   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,
     1      da,dg,vxsv,vysv)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function icvtst(itnum,iprob,itask,itype,ndf,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,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
            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<trf) then
            isw=1
            tola=max(relerr*tole,tola)
            if(relres<=1.0e0_rknd) tolb=max(relres*tole,tolb)
            if(reler0<0.5e0_rknd) tola=max(reler0*tole,tola)
        endif
c
c       convergence test
c
        icvtst=0
        if(relerr<tole.or.relres<tolr) icvtst=-1
        if(relerr<=tola.and.ratio<=erf) icvtst=-1
        if(relerr<=tola.and.relres<=tolb) icvtst=1
        if(min(relres,relerr)<eps*real(ndf,rknd)) icvtst=1
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function jcvtst(itnum,iprob,itask,itype,ndf,rp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd) :: jcvtst
            integer(kind=iknd), save :: isw
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), save :: tola,tolb,eps,erf,tole,tolr,trf
cy
c
c       debug convergence test for outer parallel solve
c
c       jcvtst = -1  making progress
c       jcvtst =  0  not converged
c       jcvtst =  1  converged
c
        ii=0
        if(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
            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<trf) then
            isw=1
            tola=max(relerr*tole,tola)
            if(relres<=1.0e0_rknd) tolb=max(relres*tole,tolb)
            if(reler0<0.5e0_rknd) tola=max(reler0*tole,tola)
        endif
c
c       convergence test
c
        jcvtst=0
        if(relerr<tole.or.relres<tolr) jcvtst=-1
        if(relerr<=tola.and.ratio<=erf) jcvtst=-1
        if(relerr<=tola.and.relres<=tolb) jcvtst=1
        if(min(relres,relerr)<eps*real(ndf,rknd)) jcvtst=1
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cev(ndf,ip,rp,ja,ibp,ibs,ibo,a,d,ju,u,
     +      juc,jp,uc,evl,evr)
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,
     +          ibo,juc,jp
            integer(kind=iknd), dimension(100) :: ip
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(*) :: a,evl,evr,u,uc,d
            real(kind=rknd), dimension(ndf) :: bl,br,evr0,evl0,devr,devl
            real(kind=rknd), dimension(ndf) :: aev
cy
c
c       compute approximate left and right singular vectors
c       this routine should work when evl is allocated and ispd=1
c       and also when evl=evr but ispd=0
c
        method=ip(9)
        ispd=ip(8)
        mxcg=ip(10)
        nb=ip(91)
        anorm=rp(55)
        jspd=1
        if(ispd/=1) jspd=-1
c
        tol=1.0e-3_rknd
        tol1=1.0e-1_rknd
        itmax=max(10_iknd,mxcg)
c
c       check for null vectors
c
        sval=1.0e0_rknd
        evrn=rl2nrm(ndf,evr)
        evln=rl2nrm(ndf,evl)
        if(evrn==0.0e0_rknd.or.evln==0.0e0_rknd) then
            rp(25)=sval
            return
        endif
c
c       normalize initial vectors
c
        dp=rl2ip(ndf,evl,evr)
        if(dp<0.0e0_rknd) evln=-evln
        do i=1,ndf
            ee=evr(i)/evrn
            evl(i)=evl(i)/evln
            evr(i)=ee
        enddo
        do i=1,ndf
            devr(i)=0.0e0_rknd
            devl(i)=0.0e0_rknd
            evr0(i)=0.0e0_rknd
            evl0(i)=0.0e0_rknd
        enddo
c
c       inverse iteration loop
c
        call hist1(14_iknd,0_iknd,1.0e0_rknd)
        sval0=rp(25)
        sval1=sval0
        sval2=sval0
        do itnum=1,itmax
c
c       a evr = sval * evl
c       a(transpose)  evl = sval * evr
c
            call mtxmlt(ndf,nb,ja,ibs,ibp,a,evr,aev,ispd)
            sval=rl2ip(ndf,evl,aev)
            do i=1,ndf
                br(i)=sval*evl(i)-aev(i)
                bl(i)=br(i)
            enddo
            brnorm=rl2nrm(ndf,br)
            if(ispd/=1) then
                call mtxmlt(ndf,nb,ja,ibs,ibp,a,evl,aev,jspd)
                svll=rl2ip(ndf,evr,aev)
                do i=1,ndf
                    bl(i)=svll*evr(i)-aev(i)
                enddo
                blnorm=rl2nrm(ndf,bl)
            endif
            dr=max(abs(sval-sval0),abs(sval-sval1),abs(sval-sval2))
            dr=dr/(abs(sval)+tol*anorm)
            sval0=sval1
            sval1=sval2
            sval2=sval
            call hist1(14_iknd,itnum,dr)
            if(dr<tol.and.itnum>2) 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,d,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,d,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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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(a(2,1))) j1=2
        if(abs(a(j1,1))<abs(a(3,1))) j1=3
        j2=index(2,j1)
        j3=index(3,j1)
c
        if(a(j1,1)/=0.0e0_rknd) a(j1,1)=1.0e0_rknd/a(j1,1)
        q2=a(j2,1)*a(j1,1)
        q3=a(j3,1)*a(j1,1)
        do k=1,num
            b(j2,k)=b(j2,k)-b(j1,k)*q2
            b(j3,k)=b(j3,k)-b(j1,k)*q3
        enddo
c
        a(j2,2)=a(j2,2)-a(j1,2)*q2
        a(j2,3)=a(j2,3)-a(j1,3)*q2
        a(j3,2)=a(j3,2)-a(j1,2)*q3
        a(j3,3)=a(j3,3)-a(j1,3)*q3
c
        if(abs(a(j2,2))<abs(a(j3,2))) j2=j3
        j3=6-j1-j2
        if(a(j2,2)/=0.0e0_rknd) a(j2,2)=1.0e0_rknd/a(j2,2)
        q3=a(j3,2)*a(j2,2)
        do k=1,num
            b(j3,k)=b(j3,k)-b(j2,k)*q3
        enddo
        a(j3,3)=a(j3,3)-a(j2,3)*q3
c
        if(a(j3,3)/=0.0e0_rknd) a(j3,3)=1.0e0_rknd/a(j3,3)
        do k=1,num
            x3=b(j3,k)*a(j3,3)
            x2=(b(j2,k)-a(j2,3)*x3)*a(j2,2)
            b(1,k)=(b(j1,k)-a(j1,2)*x2-a(j1,3)*x3)*a(j1,1)
            b(2,k)=x2
            b(3,k)=x3
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ev3x3(a,r,q,irank)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(3,3) :: a,q
            real(kind=rknd), dimension(3) :: r,root
cy
c       solve 3 x 3 eigenvalue problem for all special cases
c
        do i=1,3
            r(i)=0.0e0_rknd
            do j=1,3
                q(i,j)=0.0e0_rknd
            enddo
            q(i,i)=1.0e0_rknd
        enddo
        as=max(a(1,1),a(2,2),a(3,3))
        if(as==0.0e0_rknd) return
        a11=a(1,1)/as
        a22=a(2,2)/as
        a33=a(3,3)/as
        a12=a(1,2)/as
        a13=a(1,3)/as
        a23=a(2,3)/as
c
c       irank=1
c
        if(irank==1) then
            r(1)=a(1,1)
            return
        endif
        if(irank==2) then
c
c       coefficients of quadratic
c
            d12=a12**2
            b=(a11+a22)/2.0e0_rknd
            c0=max(a11*a22-d12,0.0e0_rknd)
            d=(a11-a22)/2.0e0_rknd
            d=sqrt(d*d+d12)
            r1=c0/(b+d)
            r(1)=r1*as
            r(2)=(b+d)*as
            r(3)=0.0e0_rknd
            d1=a11-r1
            d2=a22-r1
            if(max(abs(d1),abs(d2))==0.0e0_rknd) then
                c=1.0e0_rknd
                s=0.0e0_rknd
            else if(abs(d1)>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)<r(1)) ic1=2
        if(r(3)<r(ic1)) ic1=3
        ic2=(5-ic1)/2
        ic3=6-ic1-ic2
        if(r(ic3)<r(ic2)) ic2=ic3
        ic3=6-ic1-ic2
        root(1)=r(ic1)
        root(2)=r(ic2)
        root(3)=r(ic3)
        r(1)=root(1)*as
        r(2)=root(2)*as
        r(3)=root(3)*as
c
c       now get eigenvectors
c
        if(r(3)-r(1)<tol*r(3)) then
            return
        else if(min(r(2)-r(1),r(3)-r(2))<=tol*r(2)) then
            a1=a11-root(2)
            a2=a22-root(2)
            a3=a33-root(2)
            s1=a1**2+d12+d13
            s2=a2**2+d12+d23
            s3=a3**2+d13+d23
            if(s1>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 12.0 - - - june, 2016
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)<r(1)) ic1=2
        if(r(3)<r(ic1)) ic1=3
        ic2=(5-ic1)/2
        ic3=6-ic1-ic2
        if(r(ic3)<r(ic2)) ic2=ic3
        ic3=6-ic1-ic2
c
        irank=1
        if(r(ic2)>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)<abs(a12)) then
                do i=1,n
                    v2(i)=v3(i)
                enddo
            endif
            do i=1,n
                v3(i)=0.0e0_rknd
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine carea(ntf,itnode,itedge,ibndry,vx,vy,sf,
     +      nrl,rl,area,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
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(3) :: c
            real(kind=rknd), dimension(12) :: x,y
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(2,15) :: values
cy
            external sxy
            data index/1,2,3,2,3,1,3,1,2/
c
c       compute area of domain
c
        area=0.0e0_rknd
        pi=3.141592653589793e0_rknd
        do i=1,ntf
            x2=vx(itnode(2,i))-vx(itnode(1,i))
            x3=vx(itnode(3,i))-vx(itnode(1,i))
            y2=vy(itnode(2,i))-vy(itnode(1,i))
            y3=vy(itnode(3,i))-vy(itnode(1,i))
            det=abs(x2*y3-x3*y2)/2.0e0_rknd
            det0=det
c
c       curved edges
c
            do j=1,3
                if(itedge(j,i)>=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,2+nrl
                            values(1,mm)=0.0e0_rknd
                            values(2,mm)=0.0e0_rknd
                        enddo
                        theta=theta1+real(m,rknd)*dt
                        call sxy(rl,theta,itag,values)
                        x(m+1)=values(1,1)-vx(ivj)
                        y(m+1)=values(2,1)-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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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))<bmax) then
                bnorm=bnorm+(b(i)/bmax)**2
            else if(b(i)/=0.0e0_rknd) then
                bnorm=1.0e0_rknd+bnorm*(bmax/b(i))**2
                bmax=abs(b(i))
            endif
        enddo
        rl2nrm=sqrt(bnorm)*bmax
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function rl2ip(n,x,y)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y
            real(kind=rknd) :: rl2ip
cy
c       compute dot product
c
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        spmax=0.0e0_rknd
        snmax=0.0e0_rknd
        sp=0.0e0_rknd
        sn=0.0e0_rknd
        do i=1,n
            t=x(i)*y(i)
            if(t>=0.0e0_rknd) then
                if(t<spmax) then
                    sp=sp+t/spmax
                else if(t/=0.0e0_rknd) then
                    sp=1.0e0_rknd+sp*(spmax/t)
                    spmax=t
                endif
            else
                if(-t<snmax) then
                    sn=sn+t/snmax
                else
                    sn=-(1.0e0_rknd+sn*(snmax/t))
                    snmax=-t
                endif
            endif
        enddo
        sp=sp*spmax
        sn=sn*snmax
        if(abs(sp+sn)>eps*(sp-sn)) then
            rl2ip=sp+sn
        else
            rl2ip=0.0e0_rknd
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function sl2ip(n,x,y,scale)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y
            real(kind=rknd) :: sl2ip
cy
c       compute dot product
c
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        spmax=0.0e0_rknd
        snmax=0.0e0_rknd
        sp=0.0e0_rknd
        sn=0.0e0_rknd
        do i=1,n
            t=(x(i)/scale)*(y(i)/scale)
            if(t>=0.0e0_rknd) then
                if(t<spmax) then
                    sp=sp+t/spmax
                else if(t/=0.0e0_rknd) then
                    sp=1.0e0_rknd+sp*(spmax/t)
                    spmax=t
                endif
            else
                if(-t<snmax) then
                    sn=sn+t/snmax
                else
                    sn=-(1.0e0_rknd+sn*(snmax/t))
                    snmax=-t
                endif
            endif
        enddo
        sp=sp*spmax
        sn=sn*snmax
        if(abs(sp+sn)>eps*(sp-sn)) then
            sl2ip=sp+sn
        else
            sl2ip=0.0e0_rknd
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cnorms(ip,rp,itnode,itedge,vx,vy,ibmptr,bump,maxd,
     +      nef,u,ndf,itdof,maxt,e)
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(3,*) :: itedge
            integer(kind=iknd), dimension(*) :: ibmptr
            integer(kind=iknd), dimension(ndf) :: mark
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(3) :: iords
            real(kind=rknd), dimension(*) :: bump,vx,vy
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(maxt,*) :: e
            real(kind=rknd), dimension(maxd,*) :: u
            real(kind=rknd), dimension(maxt) :: t
cy
c       compute global errors estimate on distributed mesh
c
        mpisw=ip(48)
        irgn=ip(50)
        iadapt=ip(20)
        if(iadapt==-4) iadapt=4
        ndtrgt=ip(22)
        ntf=ip(1)
c
c       smooth the scaling factors
c
        itmax=1
        theta=0.5e0_rknd
        do itnum=1,itmax
            do i=1,ntf
                s=0.0e0_rknd
                num=0
                do j=1,3
                    if(itedge(j,i)<=0) cycle
                    k=itedge(j,i)/4
                    s=s+e(k,2)
                    num=num+1
                enddo
                if(num>0) 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
        eln1=0.0e0_rknd
        enrm1p=0.0e0_rknd
        enrm2p=0.0e0_rknd
        unrm1p=0.0e0_rknd
        unrm2p=0.0e0_rknd
        eln1p=0.0e0_rknd
        do i=1,ntf
            call tquali(i,itnode,vx,vy,ibmptr,bump,itdof,
     +          maxd,u,nef,erh1,erl2,uh1,ul2)
            e(i,1)=erh1
            enorm1=enorm1+erh1
            enorm2=enorm2+erl2
            unorm1=unorm1+uh1
            unorm2=unorm2+ul2
            if(erh1>0.0e0_rknd) eln1=eln1+log(erh1)
c
            if(itnode(4,i)/=irgn) cycle
            enrm1p=enrm1p+erh1
            enrm2p=enrm2p+erl2
            unrm1p=unrm1p+uh1
            unrm2p=unrm2p+ul2
            if(erh1>0.0e0_rknd) eln1p=eln1p+log(erh1)
        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)
            rp(88)=exp(eln1p/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)
            rp(88)=exp(eln1/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.ndtrgt<ndf) then
            call hist2(rp,-1_iknd,ndf)
        else
            call hist2(rp,ii,ndf)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine l2mtx(n,vx,vy,itnode,ja,a,itldof,ntl)
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,*) :: itldof
            integer(kind=iknd), dimension(*) :: ja
            integer(kind=iknd), dimension(3) :: idof
            real(kind=rknd), dimension(*) :: vx,vy,a
            real(kind=rknd), dimension(3) :: tx,ty,x,y
cy
        do i=1,ja(n+1)-1
            a(i)=0.0e0_rknd
        enddo
c
c       compute mass matrix
c
        ishift=0
        do it=1,ntl
            itri=itldof(4,it)
            call l2gmpl(it,idof,ndof,itldof)
            call afmap(itri,itnode,vx,vy,tx,ty,x,y,det)
c***        det=abs(det)/24.0e0_rknd
            det=0.25e0_rknd
            do k=1,3
                ivk=idof(k)
                a(ivk)=a(ivk)+2.0e0_rknd*det
                do j=k+1,3
                    call jamap0(ivk,idof(j),kj,jk,ja,ishift)
                    a(jk)=a(jk)+det
                enddo
            enddo
        enddo
        anorm=0.0e0_rknd
        do i=1,n
            anorm=max(anorm,abs(a(i)))
        enddo
        do i=1,n+1
            if(a(i)==0.0e0_rknd) a(i)=anorm
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine h1mtx(n,vx,vy,itnode,ja,a,itldof,ntl)
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,*) :: itldof
            integer(kind=iknd), dimension(*) :: ja
            integer(kind=iknd), dimension(3) :: idof
            real(kind=rknd), dimension(*) :: vx,vy,a
            real(kind=rknd), dimension(3) :: tx,ty,x,y
cy
        do i=1,ja(n+1)-1
            a(i)=0.0e0_rknd
        enddo
c
c       compute stiffness matrix for laplacian
c
        ishift=0
        do it=1,ntl
            itri=itldof(4,it)
            call l2gmpl(it,idof,ndof,itldof)
            call afmap(itri,itnode,vx,vy,tx,ty,x,y,det)
            det=abs(det)/2.0e0_rknd
            do k=1,3
                ivk=idof(k)
                a(ivk)=a(ivk)+det*(x(k)**2+y(k)**2)
                do j=k+1,3
                    call jamap0(ivk,idof(j),kj,jk,ja,ishift)
                    a(jk)=a(jk)+det*(x(j)*x(k)+y(j)*y(k))
                enddo
            enddo
        enddo
        anorm=0.0e0_rknd
        do i=1,n
            anorm=max(anorm,abs(a(i)))
        enddo
        do i=1,n+1
            if(a(i)==0.0e0_rknd) a(i)=anorm
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine f2cmap(nb,ntf,nbf,ndf,itdof,ibndry,ibedge,
     +      ibs,ibp,ibo,jp)
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(7) :: idof
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(*) :: jp,ibs,ibp,ibo
            integer(kind=iknd), dimension(ndf) :: map
            integer(kind=iknd), dimension(nb) :: deg
            real(kind=rknd), dimension(3) :: c
            common /pltmg1/ic(3,363),jc(12)
            common /pltmg4/fc(2541),ishift(7)
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       create coarse to fine mapping
c
        do i=1,nb
            deg(i)=0
            ibo(i)=1
            do j=1,ibs(i)
                map(j+ibp(i)-1)=i
            enddo
        enddo
        do i=1,7
           ishift(i)=(i-1)*363
        enddo
c
c       compute interpolation coefficients
c
        mxord=11
        do iord=1,mxord
            do i=jc(iord),jc(iord+1)-1
                do j=1,3
                    c(j)=real(ic(j,i),rknd)/real(iord,rknd)
                enddo
                do j=1,3
                   fc(i+ishift(j))=c(j)
                   fc(i+ishift(j+3))=
     +                  c(index(2,j))*c(index(3,j))*4.0e0_rknd
                enddo
                fc(i+ishift(7))=c(1)*c(2)*c(3)*27.0e0_rknd
            enddo
        enddo
c
c       compute pointers
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
                    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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sfhb(nb,ja,jp,ibs,ibo,a,d,maxju,ju,maxu,u,ispd,
     +      dtol,itype,method)
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,d
            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
c       diagonal blocks
c
        lend=jap(nb+1)-1
        do i=1,lend
            d(i)=a(i)
        enddo
        do i=1,nb
            call dfac(ibs(i),d(jap(i)),ispd)
        enddo
        if(method/=0) return
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 12.0 - - - june, 2016
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       fine to coarse 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 12.0 - - - june, 2016
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       fine to coarse 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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sfilu0(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(j1<j2) then
                    indx(k)=j1+1
                    j=ju(j1+1)
                    list(k)=list(j)
                    list(j)=k
                endif
                go to 20
            endif
c
            do jj=ju(i),ju(i+1)-1
                mark(ju(jj))=0
            enddo
c
            if(ju(i)<ju(i+1)) then
                j=ju(ju(i))
                list(i)=list(j)
                list(j)=i
                indx(i)=ju(i)
            endif
c
c       find vertex parents
c
            if(itype/=1) cycle
            kmax0=0
            kmax1=0
            emax0=0.0e0_rknd
            emax1=0.0e0_rknd
            do jj=ju(i),ju(i+1)-1
                j=ju(jj)
                mark(j)=0
                ee=max(abs(u(jj)),abs(u(jj+umtx)))
                if(ee>emax0) 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
            maxu=maxju
        else
            nnz=ju(n+1)-ju(1)
            maxu=maxju+nnz
            if(itype==1) then
                imtx=umtx+ju(1)-1
                kmtx=ju(n+1)-1
                do i=1,nnz
                    u(kmtx+i)=u(imtx+i)
                enddo
            endif
        endif
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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) :: amtx,umtx
            real(kind=rknd), dimension(*) :: a,u
            real(kind=rknd), dimension(n) :: tl,tu
cy
c
c       sparse numeric factorization
c
        do i=1,n
            mark(i)=0
            list(i)=0
            indx(i)=0
        enddo
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
            do i=1,n
                mark(i)=1
            enddo
        endif
c
        do i=1,n
c
c       initialize row i and col i in tu and tl
c
            if(itype==1) then
                mark(i)=i
                len=0
                do jj=ja(i),ja(i+1)-1
                    j=ja(jj)
                    tu(j)=a(jj)
                    tl(j)=a(jj+amtx)
                    mark(j)=mark(i)
                    mark(i)=j
                    len=len+1
                enddo
            else
                do jj=ju(i),ju(i+1)-1
                    j=ju(jj)
                    tu(j)=0.0e0_rknd
                    tl(j)=0.0e0_rknd
                enddo
                do jj=ja(i),ja(i+1)-1
                    j=ja(jj)
                    tu(j)=a(jj)
                    tl(j)=a(jj+amtx)
                enddo
            endif
            tu(i)=a(i)
            tl(i)=a(i)
c
c       do outer product updates
c
            lk=list(i)
   10       if(lk>0) then
                k=lk
                lk=list(k)
                j1=indx(k)
                j2=ju(k+1)-1
                su=u(j1)/u(k)
                sl=u(j1+umtx)/u(k)
                do jj=j1,j2
                    j=ju(jj)
                    xu=sl*u(jj)
                    xl=su*u(jj+umtx)
                    if(mark(j)/=0) then
                        tu(j)=tu(j)-xu
                        tl(j)=tl(j)-xl
                    else
                        tu(j)=-xu
                        tl(j)=-xl
                        mark(j)=mark(i)
                        mark(i)=j
                        len=len+1
                    endif
                enddo
                if(j1<j2) then
                    j=ju(j1+1)
                    list(k)=list(j)
                    list(j)=k
                    indx(k)=j1+1
                endif
                go to 10
            endif
c
c       make ju for this row
c
            if(itype==1) then
                next=ju(i)
                atol=rtol*abs(a(i))
                do j=1,len
                    k=mark(i)
                    if(max(abs(tl(k)),abs(tu(k)))>atol) then
                        ju(next)=k
                        next=next+1
                    endif
                    mark(i)=mark(k)
                    mark(k)=0
                enddo
                mark(i)=0
                ju(i+1)=next
                len=next-ju(i)
                if(len>1) call ihp(ju(ju(i)),len)
            endif
c
c       move tl, tu to u
c
            u(i)=tu(i)
            do jj=ju(i),ju(i+1)-1
                j=abs(ju(jj))
                u(jj)=tu(j)
                u(jj+umtx)=tl(j)
            enddo
c
            if(ju(i)<ju(i+1)) then
                j=ju(ju(i))
                list(i)=list(j)
                list(j)=i
                indx(i)=ju(i)
            endif
        enddo
c
c       shift u for non symmetric case
c
        maxju=ju(n+1)-1
        if(ispd==1) then
            maxu=maxju
        else
            nnz=ju(n+1)-ju(1)
            maxu=maxju+nnz
            if(itype==1) then
                imtx=umtx+ju(1)-1
                kmtx=ju(n+1)-1
                do i=1,nnz
                    u(kmtx+i)=u(imtx+i)
                enddo
            endif
        endif
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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)<eps) return
            else
                beta=0.0e0_rknd
            endif
            zdz=sum
c
c       backward sweep
c
            pap=0.0e0_rknd
            do i=n2,n1,-1
                ap(i)=z(i)+beta*ap(i)
                sum=0.0e0_rknd
                do j=ja(i),ja(i+1)-1
                    sum=sum+z(ja(j))*a(j)
                enddo
                z(i)=(z(i)-sum)/a(i)
                p(i)=z(i)+beta*p(i)
                pap=pap+(p(i)/zdz)*((2.0e0_rknd*ap(i)-p(i)*a(i))/zdz)
            enddo
c
            if(pap==0.0e0_rknd) return
            alpha=1.0e0_rknd/pap
c
c       update x,r
c
            do i=n1,n2
                x(i)=x(i)+alpha*p(i)
                r(i)=r(i)-alpha*ap(i)
                z(i)=r(i)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine jcg1(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) :: p,ap,z
cy
c       cg with identity preconditioner
c
c       initialize
c
        nn=n2-n1+1
        zdz=0.0e0_rknd
        relerr=1.0e0_rknd
        do i=n1,n2
            r(i)=r(i)-a(i)*x(i)
            do jj=ja(i),ja(i+1)-1
                j=ja(jj)
                r(i)=r(i)-a(jj)*x(j)
                r(j)=r(j)-a(jj)*x(i)
            enddo
            p(i)=0.0e0_rknd
        enddo
c
c       the main loop
c
        do itnum=1,mxcg
c
c       compute alpha and pecondition
c
            snrm=rl2nrm(nn,r(n1))
            if(snrm==0.0e0_rknd) return
            sum=0.0e0_rknd
            do i=n1,n2
                z(i)=r(i)/a(i)
cc              z(i)=r(i)
                sum=sum+(r(i)/snrm)*(z(i)/snrm)
            enddo
            sum=sqrt(sum)*snrm
            if(itnum>1) then
                if(zdz==0.0e0_rknd) return
                beta=(sum/zdz)**2
                relerr=relerr*beta
                if(sqrt(relerr)<eps) return
            else
                beta=0.0e0_rknd
            endif
            zdz=sum
            do i=n1,n2
                p(i)=z(i)+beta*p(i)
                ap(i)=a(i)*p(i)
            enddo
            pap=0.0e0_rknd
            do i=n1,n2
                do jj=ja(i),ja(i+1)-1
                    j=ja(jj)
                    ap(i)=ap(i)+a(jj)*p(j)
                    ap(j)=ap(j)+a(jj)*p(i)
                enddo
                pap=pap+(p(i)/zdz)*(ap(i)/zdz)
            enddo
            if(pap==0.0e0_rknd) return
            alpha=1.0e0_rknd/pap
            do i=n1,n2
                x(i)=x(i)+alpha*p(i)
                r(i)=r(i)-alpha*ap(i)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function dl2nrm(n,b,d,isw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: b,d
            real(kind=rknd) :: dl2nrm
cy
c       compute norm of b and update history
c
        bnorm=0.0e0_rknd
        bmax=0.0e0_rknd
        do i=1,n
            dd=0.0e0_rknd
            if(isw>=0) then
                dd=d(i)
            else
                if(d(i)/=0.0e0_rknd) dd=1.0e0_rknd/d(i)
            endif
            if(abs(b(i))<bmax) then
                bnorm=bnorm+dd*(b(i)/bmax)**2
            else if(b(i)/=0.0e0_rknd) then
                bnorm=dd+bnorm*(bmax/b(i))**2
                bmax=abs(b(i))
            endif
        enddo
        dl2nrm=sqrt(bnorm)*bmax
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function dl2ip(n,x,y,d,isw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y,d
            real(kind=rknd) :: dl2ip
cy
c       compute dot product
c
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        spmax=0.0e0_rknd
        snmax=0.0e0_rknd
        sp=0.0e0_rknd
        sn=0.0e0_rknd
        do i=1,n
            t=0.0e0_rknd
            if(isw>=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(t<spmax) then
                    sp=sp+t/spmax
                else if(t/=0.0e0_rknd) then
                    sp=1.0e0_rknd+sp*(spmax/t)
                    spmax=t
                endif
            else
                if(-t<snmax) then
                    sn=sn+t/snmax
                else
                    sn=-(1.0e0_rknd+sn*(snmax/t))
                    snmax=-t
                endif
            endif
        enddo
        sp=sp*spmax
        sn=sn*snmax
        if(abs(sp+sn)>eps*(sp-sn)) then
            dl2ip=sp+sn
        else
            dl2ip=0.0e0_rknd
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mkgm(ndf,ntf,vx,vy,gm,itnode,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
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(3) :: iords
            real(kind=rknd), dimension(*) :: vx,vy,gm
cy
c       compute diag of gram matrix
c
        do i=1,ndf
            gm(i)=0.0e0_rknd
        enddo
        do i=1,ntf
            x2=vx(itnode(2,i))-vx(itnode(1,i))
            y2=vy(itnode(2,i))-vy(itnode(1,i))
            x3=vx(itnode(3,i))-vx(itnode(1,i))
            y3=vy(itnode(3,i))-vy(itnode(1,i))
            det=abs(x2*y3-x3*y2)/12.0e0_rknd
c
            call l2gmap(i,idof,ndof,iord,iords,itdof)
            do j=1,3
                gm(idof(j))=gm(idof(j))+det
            enddo
            do j=4,3*iord
                gm(idof(j))=gm(idof(j))+det*3.0e0_rknd
            enddo
            do j=3*iord+1,ndof
                gm(idof(j))=gm(idof(j))+det*6.0e0_rknd
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine centre(x1,y1,x2,y2,x3,y3,xc,yc)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
cy
c       compute the center of the circle which passes
c       through (x1,y1), (x2,y2), and (x3,y3)
c
        z1=x1-x3
        z2=x2-x3
        w1=y1-y3
        w2=y2-y3
        det=(z1*w2-z2*w1)*2.0e0_rknd
        if(det/=0.0e0_rknd) then
            r1=(z1*(x1+x3)+w1*(y1+y3))/det
            r2=(z2*(x2+x3)+w2*(y2+y3))/det
            xc=r1*w2-r2*w1
            yc=z1*r2-z2*r1
        else
            xc=x1
            yc=y1
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine midpt(x1,y1,x2,y2,xc,yc,x,y)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
cy
c       compute the midpoint of the circle with center (xc,yc)
c       which passes through the points (x1,y1),(x2,y2).
c       the midpoint (x,y) is relative to the shorter
c       of the two arcs.
c
        x=(x1+x2)/2.0e0_rknd
        y=(y1+y2)/2.0e0_rknd
        c=(x+x1-2.0e0_rknd*xc)*(x1-x)+(y+y1-2.0e0_rknd*yc)*(y1-y)
        if(c<=0.0e0_rknd) return
        dy=y1-y2
        dx=x1-x2
        b=(x-xc)*dy-(y-yc)*dx
        a=dx*dx+dy*dy
        a=c/(abs(b)+sqrt(b*b+a*c))
        if(b<0.0e0_rknd)  a=-a
        x=x+a*dy
        y=y-a*dx
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine gfptr(ip,iuu,iu0,iudot,iu0dot,
     +          ievr,ievl,ivx0,ivy0,ium,iuc,iudl)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(100) :: ip
cy
        iprob=abs(ip(6))
        maxd=ip(85)
        ngf=ip(77)
        nproc=ip(49)
c
c       set grid function pointers
c
        iuu=1
c
        iu0=1
        iudot=1
        iu0dot=1
        ievr=1
        ievl=1
c
        ivx0=1
        ivy0=1
c
        ium=1
        iuc=1
        iudl=1
c
        if(iprob==1) then
            ium=iuu+maxd
        else if(iprob==3) then
            iu0=iuu+maxd
            iudot=iu0+maxd
            iu0dot=iudot+maxd
            ievr=iu0dot+maxd
            ievl=ievr+maxd
c
c       ngf=6 in case the user changes ispd=1 to ispd=0 after init.
c
        else if(iprob==4) then
            ium=iuu+maxd
            iudot=ium+maxd
        else if(iprob==5) then
            ium=iuu+maxd
            iuc=ium+maxd
        else if(iprob==6) then
            iu0=iuu+maxd
            ivx0=iu0+maxd
            ivy0=ivx0+maxd
            ievr=ivx0
            ievl=ivy0
            ium=iu0
        endif
        if(nproc>1) iudl=iuu+(ngf-1)*maxd
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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
        nvf=ip(2)
        ndf=ip(4)
        nrl=ip(13)
        iprob=ip(6)
        itask=ip(7)
        ispd=ip(8)
        method=ip(9)
c
        nb=ip(91)
        lenja=ip(92)
        lenad=ip(93)
        lenadn=ip(93)*2-ndf
        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) then
            isize(4)=lenas
            isize(5)=nrl*nrl
            isize(6)=ndf*nrl
        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       isize(25)=uad
c       isize(26)=ugd
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(ispd==1) then
            isize(25)=lenad
        else
            isize(25)=lenadn
        endif
        if(abs(iprob)==5) then
            isize(21)=isize(1)
            isize(24)=isize(11)
            isize(26)=lenad
        endif
c
        if(method/=1) then
            isize(11)=1
            isize(12)=1
            isize(13)=1
            isize(14)=1
        endif
        if(method/=0) then
           isize(21)=1
           isize(22)=1
           isize(23)=1
           isize(24)=1
        endif
        if(method==1) then
           isize(25)=1
           isize(26)=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(39)=vxsv,vysv
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) then
            isize(32)=ndf
            isize(33)=nrl
            isize(34)=nrl
            isize(35)=ndf
            isize(37)=ndf*nrl
            isize(38)=nrl
            if(itask==8) isize(39)=nvf
        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-(ip(33)+ip(36)-ip(30))
c
        isize(41)=lenja0
        if(ispd==1) then
            isize(42)=lenja0
        else
            isize(42)=maxa0n
        endif
c
        if(iprob==-2) then
            isize(31)=ndf+ndd
        else if(iprob==-3) then
            isize(35)=ndf+ndd
            isize(36)=ndf+ndd
        else if(iprob==-4) then
            isize(6)=(ndf+ndd)*nrl
            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 12.0 - - - june, 2016
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
        iprob=abs(ip(6))
        itask=ip(7)
        nproc=ip(49)
        nrl=ip(13)
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) then
            ngf=2+nrl
            nef=2
        else if(iprob==5) then
            ngf=3
            nef=3
        else if(iprob==6) 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
        if(iprob==1.or.iprob==3) then
            rp(63)=0.0e0_rknd
        else
            rp(63)=rp(3)
        endif
        rp(64)=0.0e0_rknd
        rp(65)=0.0e0_rknd
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine setcom(ip)
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), save :: ifirst=1
cy
c
c       set up pltmg common blocks
c
c
c       pointers for coefficient functions
c
        call setval(ip)
        if(ifirst==0) return
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 12.0 - - - june, 2016
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(29)
        tmtol=rp(30)
        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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine gf2nd(ntf,nvf,nbf,nrl,rl,itnode,ibndry,itdof,sf,
     +      vx,vy,vxgf,vygf,isw,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3) :: iords
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(3,ntf) :: icurv
            integer(kind=iknd), dimension(2,nbf) :: ibedge
            real(kind=rknd), dimension(*) :: vx,vy,vxgf,vygf,rl
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(100) :: xp,yp
cy
            external sxy
c
c       isw = 0 (vxgf,vygf) --> (vx,vy)
c       isw = 1 (vx,vy) --> (vxgf,vygf)
c
        if(isw==0) then
c
c       grid functions to nodes
c
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                do j=1,3
                    vx(itnode(j,i))=vxgf(idof(j))
                    vy(itnode(j,i))=vygf(idof(j))
                enddo
            enddo
        else
c
c       nodes to grid functions
c
            call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,kflag)
            call ccurv(ntf,nbf,ibndry,ibedge,icurv)
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                call cnode2(i,itnode,ibndry,itdof,icurv,vx,vy,
     +              nrl,rl,sf,xp,yp,jsw,sxy)
                do j=1,ndof
                    vxgf(idof(j))=xp(j)
                    vygf(idof(j))=yp(j)
                enddo
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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<tol*abs(sigma).or.
     +      abs(rqnew)<tol*rqmx) then
            isw=-1
            return
        endif
c
        if(rqnew-rqold/=0.0e0_rknd) then
            qq=signew-rqnew*(signew-sigold)/(rqnew-rqold)
            qlow=abs(qq-siglow)
            qup=abs(qq-sigup)
            if(max(qlow,qup)<=ds*(1.0e0_rknd-tol)) then
                sigma=qq
            else if(qlow<=ds*tol) then
                sigma=siglow+(sigup-siglow)*tol
            else if(qup<=ds*tol) then
                sigma=sigup+(siglow-sigup)*tol
            endif
        endif
        rp(71)=sigma
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tpick(ndf,ip,rp,vx,vy,vxsv,vysv,itnode,ibndry,ibedge,
     +      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,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(2,*) :: ibedge
            integer(kind=iknd), dimension(*) :: ja,ibs,ibp
            integer(kind=iknd), dimension(8,*) :: itdof
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(*) :: vx,vy,u,um,uc,usv,umsv,du,
     +          ucsv,a,h,g,su,sm,b,d,p,dl,bdlwr,bdupr,dum,duc,vxsv,vysv
            real(kind=rknd), dimension(ndf) :: gm
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(10), save  :: rlsv,rl
            real(kind=rknd), save :: 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
        nrl=ip(13)
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        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
                call stepmx(ndf,u,du,bdlwr,bdupr,step0)
                do i=1,ndf
                    usv(i)=u(i)
                enddo
            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(1)=rp(21)
                step0=1.0e0_rknd
            endif
        else if(iprob==4) then
            do i=1,nrl
                rl(i)=rp(90+i)
            enddo
            call norm4(ndf,ip,rp,isw,itnum,u,um,rl,du,dum,duc,
     +          ja,ibs,ibp,a,h,g,su,sm,b,p,dl,bdlwr,bdupr,gm)
            if(isw<=0) then
                call stepmx(nrl,rl,duc,bdlwr,bdupr,step0)
                do i=1,ndf
                    usv(i)=u(i)
                    umsv(i)=um(i)
                enddo
                do i=1,nrl
                    rlsv(i)=rl(i)
                enddo
                if(itask==8) then
                    do i=1,nvf
                        vxsv(i)=vx(i)
                        vysv(i)=vy(i)
                    enddo
                    call sxstep(nbf,ntf,nrl,step0,duc,ip,rlsv,
     +                  itnode,ibndry,ibedge,sf,vx,vy,sxy)
                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
                call stepmx(ndf,uc,duc,bdlwr,bdupr,step0)
                do i=1,ndf
                    usv(i)=u(i)
                    umsv(i)=um(i)
                    ucsv(i)=uc(i)
                enddo
            endif
        else
            call norm6(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,ndf)
        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(1)+step*delta
        else if(iprob==4) then
            do i=1,nrl
                rp(90+i)=rlsv(i)+step*duc(i)
            enddo
            do i=1,ndf
                um(i)=umsv(i)+step*dum(i)
            enddo
            if(itask==8) then
                do i=1,nvf
                    vx(i)=vxsv(i)
                    vy(i)=vysv(i)
                enddo
                call mfe2a(ntf,nvf,nbf,ip,rp,itnode,ibndry,itdof,u,
     +              vx,vy,sf,sxy,0_iknd)
            endif
        else if(iprob==5) then
            do i=1,ndf
                um(i)=umsv(i)+step*dum(i)
                uc(i)=ucsv(i)+step*duc(i)
            enddo
        endif
        do i=1,ndf
            u(i)=usv(i)+step*du(i)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sxstep(nbf,ntf,nrl,step,duc,ip,rl,
     +      itnode,ibndry,ibedge,sf,vx,vy,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(ntf) :: list
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(*) :: vx,vy,duc
            real(kind=rknd), dimension(10) :: rl0,rl
cy
            external sxy
c
        itnum=0
        itmax=50
cc      step0=step
        len=0
        qmin=1.0e0_rknd
        do i=1,nbf
            if(ibndry(3,i)>=0) cycle
            do j=1,2
                if(ibedge(j,i)<=0) cycle
                k=ibedge(j,i)/4
                len=len+1
                list(len)=k
                q=geom(itnode(1,k),itnode(2,k),itnode(3,k),vx,vy)
                qmin=min(q,qmin)
            enddo
        enddo
        if(qmin<=0.0e0_rknd) stop 7271
   10   do i=1,nrl
            rl0(i)=rl(i)+step*duc(i)
        enddo
        call csf(ip,rl0,vx,vy,ibndry,sf,sxy)
        qmax=1.0e0_rknd
        do i=1,len
            k=list(i)
            q=geom(itnode(1,k),itnode(2,k),itnode(3,k),vx,vy)
            qmax=min(q,qmax)
        enddo
        if(qmax> 0.0e0_rknd) return
cc      if(qmax>=qmin/2.0e0_rknd) return
        step=step/2.0e0_rknd
        itnum=itnum+1
        if(itnum<=itmax) go to 10
        if(qmax<=0.0e0_rknd) stop 7771
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cstep(rp,iexsw,isw,step0,n)
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<0.98e0_rknd) then
                frac=max(0.75e0_rknd,0.98e0_rknd-rp(63))
                step=min(step,frac*step0)
            else
                step=1.0e0_rknd
            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
c
c       test with dnew<=eps due to roundoff error at convergence
c
        if(ds<=tol.and.dnew<=eps) isw=-1
        if(ratio<=1.0e0_rknd-eps*snew.and.dnew<=eps) isw=-1
        if(min(relerr,relres)<=eps*real(n,rknd)) 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)<rr) then
c
c       b > 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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine stepmx(n,u,du,bdlwr,bdupr,step)
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
cy
c       compute maximum step for interior point
c
        step=1.0e0_rknd
        do i=1,n
            if(du(i)<0.0e0_rknd) then
                step=min((bdlwr(i)-u(i))/du(i),step)
            else if(du(i)>0.0e0_rknd) then
                step=min((bdupr(i)-u(i))/du(i),step)
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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), dimension(10) :: rl
            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(1)=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)
            q=(unorm+abs(rl(1)))*1.0e-3_rknd
            relerr=1.0e0_rknd
            if(unorm>enorm) relerr=enorm/(unorm+q)
            if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd
            rlerr=1.0e0_rknd
            if(abs(rl(1))>abs(delta)) rlerr=abs(delta)/(abs(rl(1))+q)
            if(abs(rl(1))+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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine norm4(ndf,ip,rp,isw,itnum,u,um,rl,du,dum,drl,
     +      ja,ibs,ibp,a,h,g,su,sm,b,p,dl,bdlwr,bdupr,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,du,dum,a,h,g,su
            real(kind=rknd), dimension(*) :: sm,b,p,dl,gm,bdupr,bdlwr
            real(kind=rknd), dimension(ndf) :: adu,hdu,adum
            real(kind=rknd), dimension(10) :: gdrl,rl,drl
            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=4
c
        nb=ip(91)
        nrl=ip(13)
        ispd=ip(8)
        jspd=1
        if(ispd/=1) jspd=-1
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,adum,jspd)
        call mtxmlt(ndf,nb,ja,ibs,ibp,a,du,adu,ispd)
        do i=1,ndf
            hdu(i)=hdu(i)+adum(i)
            do j=1,nrl
                idx=i+(j-1)*ndf
                hdu(i)=hdu(i)+su(idx)*drl(j)
                adu(i)=adu(i)+sm(idx)*drl(j)
            enddo
        enddo
c
        bnorm=dl2nrm(ndf,b,gm,-1_iknd)
        bmnorm=dl2nrm(ndf,p,gm,-1_iknd)
        bcnorm=rl2nrm(nrl,dl)
        bnorm=sqrt(bcnorm**2+bnorm**2+bmnorm**2)
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)
            rlnorm=rl2nrm(nrl,rl)
            bupnrm=rl2nrm(nrl,bdupr)
            blwnrm=rl2nrm(nrl,bdlwr)
            rlnorm=max(rlnorm,bupnrm,blwnrm)
            ecnorm=rl2nrm(nrl,drl)
c
c       compute relerr
c
            q=(uunorm+umnorm+rlnorm)*1.0e-3_rknd
            rulerr=1.0e0_rknd
            if(uunorm+q>eunorm) rulerr=eunorm/(uunorm+q)
            if(uunorm+eunorm<=0.0e0_rknd) rulerr=0.0e0_rknd
            rmlerr=1.0e0_rknd
            if(umnorm+q>emnorm) rmlerr=emnorm/(umnorm+q)
            if(umnorm+emnorm<=0.0e0_rknd) rmlerr=0.0e0_rknd
            rclerr=1.0e0_rknd
            if(rlnorm+q>ecnorm) rclerr=ecnorm/(rlnorm+q)
            if(rlnorm+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
c       parameter block
c
        call dmlt(nrl,g,drl,gdrl,1_iknd)
c
        uip=dl2ip(ndf,b,adu,gm,-1_iknd)
        umip=dl2ip(ndf,p,hdu,gm,-1_iknd)
cc      rlip=rl2ip(nrl,dl,gdrl)
        do i=1,nrl
            k=(i-1)*ndf+1
            gdrl(i)=gdrl(i)+rl2ip(ndf,su(k),du)+rl2ip(ndf,sm(k),dum)
        enddo
        rlip=rl2ip(nrl,dl,gdrl)
c
        ddnew=-(uip+umip+rlip)/bnorm0**2
        rp(58)=ddnew
        blast=bnorm
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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
            q=(uunorm+umnorm+ucnorm)*1.0e-3_rknd
            rulerr=1.0e0_rknd
            if(uunorm>eunorm) rulerr=eunorm/(uunorm+q)
            if(uunorm+eunorm<=0.0e0_rknd) rulerr=0.0e0_rknd
            rmlerr=1.0e0_rknd
            if(umnorm>emnorm) rmlerr=emnorm/(umnorm+q)
            if(umnorm+emnorm<=0.0e0_rknd) rmlerr=0.0e0_rknd
            rclerr=1.0e0_rknd
            if(ucnorm>ecnorm) rclerr=ecnorm/(ucnorm+q)
            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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine norm6(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=6
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tpickd(ndf,ip,rp,vx,vy,vxsv,vysv,itnode,ibndry,
     +      ibedge,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,ipath,ir0,map,
     2      ja0,a0,h0,g0,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(2,*) :: ibedge
            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,vxsv,vysv
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(ndf) :: gm
            real(kind=rknd), save, dimension(10) :: rlsv,rl
            real(kind=rknd), save :: 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
        nrl=ip(13)
        ndf=ip(4)
        nn=ip(71)
        newntf=ip(27)
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        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
                call stepmx(ndf,u,du,bdlwr,bdupr,step0)
                do i=1,ndf
                    usv(i)=u(i)
                enddo
            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(1)=rp(21)
                step0=1.0e0_rknd
            endif
        else if(iprob==4) then
            do i=1,nrl
                rl(i)=rp(90+i)
            enddo
            call norm4p(ndf,ip,rp,isw,itnum,u,um,rl,du,dum,duc,ja,
     +          ibs,ibp,a,h,g,su,sm,b,p,dl,ipath,ir0,map,ja0,a0,h0,
     1          nn,bdlwr,bdupr,gm)
            if(isw<=0) then
                call stepmx(nrl,rl,duc,bdlwr,bdupr,step0)
                do i=1,ndf
                    usv(i)=u(i)
                    umsv(i)=um(i)
                enddo
                do i=1,nrl
                    rlsv(i)=rl(i)
                enddo
                if(itask==8) then
                    do i=1,nvf
                        vxsv(i)=vx(i)
                        vysv(i)=vy(i)
                    enddo
                    call sxstep(nbf,ntf,nrl,step0,duc,ip,rlsv,
     +                  itnode,ibndry,ibedge,sf,vx,vy,sxy)
                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
                call stepmx(ndf,uc,duc,bdlwr,bdupr,step0)
                do i=1,ndf
                    usv(i)=u(i)
                    umsv(i)=um(i)
                    ucsv(i)=uc(i)
                enddo
            endif
        else
            call norm6p(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,ndf)
        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(1)+step*delta
        else if(iprob==4) then
            do i=1,nrl
                rp(90+i)=rlsv(i)+step*duc(i)
            enddo
            do i=1,ndf
                um(i)=umsv(i)+step*dum(i)
            enddo
            if(itask==8) then
                do i=1,nvf
                    vx(i)=vxsv(i)
                    vy(i)=vysv(i)
                enddo
                call mfe2a(ntf,nvf,nbf,ip,rp,itnode,ibndry,itdof,u,
     +              vx,vy,sf,sxy,0_iknd)
            endif
        else if(iprob==5) then
            do i=1,ndf
                um(i)=umsv(i)+step*dum(i)
                uc(i)=ucsv(i)+step*duc(i)
            enddo
        endif
        do i=1,ndf
            u(i)=usv(i)+step*du(i)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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=bnorm
                rp(59)=bnorm0
                bmnrm0=bmnorm
                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 12.0 - - - june, 2016
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=bnorm
                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 12.0 - - - june, 2016
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,rl
            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(1)=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))
            q=(unorm+abs(rl(1)))*1.0e-3_rknd
            relerr=1.0e0_rknd
            if(unorm>enorm) relerr=enorm/(unorm+q)
            if(unorm+enorm<=0.0e0_rknd) relerr=0.0e0_rknd
            rlerr=1.0e0_rknd
            if(abs(rl(1))>abs(delta)) rlerr=abs(delta)/(abs(rl(1))+q)
            if(abs(rl(1))+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=bnorm
                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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine norm4p(ndf,ip,rp,isw,itnum,u,um,rl,du,dum,drl,ja,
     +      ibs,ibp,a,h,g,su,sm,b,p,dl,ipath,ir0,map,ja0,a0,h0,nn,
     1      bdlwr,bdupr,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,um,du,dum,a,h,g,su,sm,b
            real(kind=rknd), dimension(*) :: p,dl,a0,h0,gm,bdlwr,bdupr
            real(kind=rknd), dimension(nn,11) :: gf
            real(kind=rknd), dimension(ndf) :: adu,adum,hdu
            real(kind=rknd), dimension(10) :: gdrl,rl,drl
            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
        nb=ip(91)
        nrl=ip(13)
        ndf=ip(4)
        newndf=ip(30)
        ndd=ip(33)
        irgn=ip(50)
c
        num=5
        ispd=ip(8)
        jspd=1
        if(ispd/=1) jspd=-1
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)
        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)
            do j=1,nrl
                idx=i+(j-1)*(ndf+ndd)
                hdu(i)=hdu(i)+su(idx)*drl(j)
                adu(i)=adu(i)+sm(idx)*drl(j)
            enddo
        enddo
c
        t(1)=dl2ip(newndf,b,b,gm,-1_iknd)
        t(2)=dl2ip(newndf,p,p,gm,-1_iknd)
        bcnorm=rl2nrm(nrl,dl)
        t(3)=dl2ip(newndf,b,adu,gm,-1_iknd)
        t(4)=dl2ip(newndf,p,hdu,gm,-1_iknd)
        do i=1,nrl
            k=(i-1)*(ndf+ndd)+1
            t(4+i)=rl2ip(newndf,su(k),du)+rl2ip(newndf,sm(k),dum)
        enddo
c
        if(isw<=0) then
            eps=1.0e2_rknd*epsilon(1.0e0_rknd)
            t(5+nrl)=dl2ip(newndf,u,u,gm,1_iknd)
            t(6+nrl)=dl2ip(newndf,um,um,gm,1_iknd)
            t(7+nrl)=dl2ip(newndf,du,du,gm,1_iknd)
            t(8+nrl)=dl2ip(newndf,dum,dum,gm,1_iknd)
c
            ii=8+nrl
            call pl2ip(t,ii)
c
            uunorm=sqrt(t(5+nrl))
            umnorm=sqrt(t(6+nrl))
            eunorm=sqrt(t(7+nrl))
            emnorm=sqrt(t(8+nrl))
            rlnorm=rl2nrm(nrl,rl)
            bupnrm=rl2nrm(nrl,bdupr)
            blwnrm=rl2nrm(nrl,bdlwr)
            rlnorm=max(rlnorm,bupnrm,blwnrm)
            ecnorm=rl2nrm(nrl,drl)
c
c       compute relerr
c
            q=(uunorm+umnorm+abs(rl(1)))*1.0e-3_rknd
            rulerr=1.0e0_rknd
            if(uunorm+q>eunorm) rulerr=eunorm/(uunorm+q)
            if(uunorm+eunorm<=0.0e0_rknd) rulerr=0.0e0_rknd
            rmlerr=1.0e0_rknd
            if(umnorm+q>emnorm) rmlerr=emnorm/(umnorm+q)
            if(umnorm+emnorm<=0.0e0_rknd) rmlerr=0.0e0_rknd
            rclerr=1.0e0_rknd
            if(rlnorm+q>ecnorm) rclerr=ecnorm/(rlnorm+q)
            if(rlnorm+ecnorm<=0.0e0_rknd) rclerr=0.0e0_rknd
            rp(54)=rulerr+rmlerr+rclerr
c
            bnorm=sqrt(bcnorm**2+t(1)+t(2))
            if(bnorm<=0.0e0_rknd) bnorm=eps
            if(itnum==1) then
                bnorm0=bnorm
                rp(59)=bnorm0
            endif
        else
            ii=4+nrl
            call pl2ip(t,ii)
            bnorm=sqrt(bcnorm**2+t(1)+t(2))
            rp(56)=bnorm/bnorm0
            rp(57)=bnorm/blast
        endif
c
c       parameter block
c
        call dmlt(nrl,g,drl,gdrl,1_iknd)
c
        uip=t(3)
        umip=t(4)
cc      rlip=rl2ip(nrl,dl,gdrl)
        do i=1,nrl
            gdrl(i)=gdrl(i)+t(4+i)
        enddo
        rlip=rl2ip(nrl,dl,gdrl)
c
        ddnew=-(uip+umip+rlip)/bnorm0**2
        rp(58)=ddnew
        blast=bnorm
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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))
            q=(uunorm+umnorm+ucnorm)*1.0e-3_rknd
            rulerr=1.0e0_rknd
            if(uunorm>eunorm) rulerr=eunorm/(uunorm+q)
            if(uunorm+eunorm<=0.0e0_rknd) rulerr=0.0e0_rknd
            rmlerr=1.0e0_rknd
            if(umnorm>emnorm) rmlerr=emnorm/(umnorm+q)
            if(umnorm+emnorm<=0.0e0_rknd) rmlerr=0.0e0_rknd
            rclerr=1.0e0_rknd
            if(ucnorm>ecnorm) rclerr=ecnorm/(ucnorm+q)
            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=bnorm
                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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine norm6p(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=-6
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=bnorm
                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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine csf(ip,rl,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(2,15) :: values
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
cy
            external sxy
c
c       compute vertices on parameterized edges
c
        nrl=ip(13)
        nbf=ip(3)
        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,2+nrl
                    values(1,k)=0.0e0_rknd
                    values(2,k)=0.0e0_rknd
                enddo
                call sxy(rl,ss,itag,values)
                vx(iv)=values(1,1)
                vy(iv)=values(2,1)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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
            hist(mxhist+1,ihist)=0.0e0_rknd
        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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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)
            hist(mxhist+1,ihist)=0.0e0_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 12.0 - - - june, 2016
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(41)=real(nsum,rknd)
            rp(42)=esum
            rp(43)=0.0e0_rknd
            rp(44)=0.0e0_rknd
        else
            rp(43)=real(nsum,rknd)
            rp(44)=esum
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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(j<i) cycle
c
c       mark periodic vertices (vtype=9 have one equivalence)
c
            do mm=1,2
                iv=ibndry(mm,i)
                jv=ibndry(3-mm,j)
                it=iv
   40           it=iequv(it)
                if(it==jv) cycle
                if(it/=iv) go to 40
                it=iequv(iv)
                iequv(iv)=iequv(jv)
                iequv(jv)=it
            enddo
        enddo
c
c       make all equivalent vertices point at a smallest member
c
        if(isw==0) return
        do i=1,nvf
            if(iequv(i)<=0) cycle
            num=1
            imin=i
            next=i
   70       next=iequv(next)
            if(next/=i) then
                imin=min(imin,next)
                num=num+1
                go to 70
            endif
            last=imin
            do k=1,num
                next=iequv(last)
                iequv(last)=-imin
                last=next
            enddo
        enddo
        do i=1,nvf
            iequv(i)=-iequv(i)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
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(*) :: iseed,vtype
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(500) :: elist,tlist,vlist
            integer(kind=iknd), dimension(500) :: blist
            integer(kind=iknd), dimension(2,*) :: ibedge
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
cy
c
c       vtype(i) =  1  internal vertex
c       vtype(i) =  2  interface vertex with no interface edge
c       vtype(i) =  3  interface corner with no interface edge
c       vtype(i) =  4  interface vertex with interface edge
c       vtype(i) =  5  mpi interface vertex leaf
c       vtype(i) =  6  interface corner with interface edge
c       vtype(i) =  7  boundary vextex
c       vtype(i) =  8  boundary corner
c       vtype(i) =  9  boundary vextex with linked edge
c       vtype(i) = 10  boundary corner with linked edge
c
c       initailize iseed to seed triangle/edge for vertex i
c
        do i=1,nvf
            vtype(i)=1
        enddo
        do i=1,nbf
            if(ibndry(4,i)>0) 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,itedge,vtype,
     +          angmin,arcmax,vlist,tlist,elist,len)
        enddo
c
        call cedge5(nbf,itedge,ibedge,0_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tstvty(i,itnode,ibndry,vx,vy,sf,itedge,
     +      vtype,angmin,arcmax,vlist,tlist,elist,len)
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
            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)<angmin) vtype(i)=2
        else if(vtype(i)==4) then
            vtype(i)=6
            if(tot/=2) return
            if(rgnct==2) then
                ie1=jb(1)
                ie2=jb(2)
                if(ie1<=0.or.ie2<=0) stop 9323
                if(ibndry(5,ie1)==0.or.ibndry(5,ie2)==0) return
c
                if(abs(ibndry(5,ie1))/=abs(ibndry(5,ie2))) return
                it1=ibndry(6,ie1)+1
                it2=ibndry(6,ie2)+1
                if(it2>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)<angmin) vtype(i)=4
                else
                    iv1=vlist(iv(1))
                    iv2=vlist(iv(2))
                    if(ibndry(3,ie1)>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)<angmin) vtype(i)=7
            else if(ibndry(3,ie1)>0) then
                tol=1.0e-1_rknd
                iv(1)=vlist(2)
                iv(2)=vlist(len+1)
                iv(3)=i
                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) then
                    vtype(i)=7
                    return
                endif
                do kk=3,len
                    k=vlist(kk)
                    call bari(vx(k),vy(k),vx,vy,iv,c)
                    if(min(c(1),c(2),c(3))>=-tol) return
                enddo
            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)<angmin) vtype(i)=9
            else
                iv1=vlist(2)
                iv2=vlist(len+1)
                if(ibndry(3,ie1)>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 12.0 - - - june, 2016
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(kson<len) then
            if(qual(p(kson+1))>qual(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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cequve(nvf,nbf,ibndry,iequv,ja)
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,ja
cy
c       initialize iequv
c
        len=ja(nvf+1)-1
        do i=1,len
            iequv(i)=i
        enddo
c
c       set up equivalence classes for linked edges
c
        do i=1,nbf
            if(ibndry(4,i)>=0) cycle
            k=-ibndry(4,i)
            if(i>k) cycle
            iv1=ibndry(1,i)
            iv2=ibndry(2,i)
            call jamap0(iv1,iv2,j,jj,ja,0_iknd)
            kv1=ibndry(1,k)
            kv2=ibndry(2,k)
            call jamap0(kv1,kv2,m,mm,ja,0_iknd)
            iequv(j)=m
            iequv(m)=j
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mkblk(ndf,ntf,nb,ibs,ibp,itdof,nptr)
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,nptr
            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
        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
        nptr(1)=1
        nptr(2)=1+nbt
        nptr(3)=1+nbt+nbe
        nptr(4)=nb+1
        nptr(5)=ndf
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 12.0 - - - june, 2016
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(10) :: rl
            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
        call setcom(ip)
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        nrl=ip(13)
        iprob=abs(ip(6))
        if(iprob==4) then
            do i=1,nrl
                rl(i)=rp(90+i)
            enddo
        else
            rl(1)=rp(21)
        endif
        call xybox(nbf,vx,vy,sf,ibndry,rp(16),rp(18),rp(78),
     +      nrl,rl,sxy)
        if(itnode(3,1)==0) then
            call sklchk(ntf,nvf,nbf,itnode,ibndry,
     +          vx,vy,sf,nrl,rl,rp(78),iflag,sxy)
            ip(4)=0
        else
            call trichk(ntf,nvf,nbf,itnode,ibndry,
     +          vx,vy,sf,nrl,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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine trichk(ntf,nvf,nbf,itnode,ibndry,
     +      vx,vy,sf,nrl,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(10) :: rl
            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,nrl,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,nrl,
     +      rl,area,sxy)
c
c       initialize region labels
c
        do i=1,ntf
           itnode(4,i)=0
        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 12.0 - - - june, 2016
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<i) cycle
                iv2=itnode(index(2,j),i)
                iv3=itnode(index(3,j),i)
                ivi=itnode(j,i)
                ivk=itnode(m,k)
                qi=geom(ivi,iv2,iv3,vx,vy)
                qk=geom(ivk,iv2,iv3,vx,vy)
                if(qi*qk>=0.0e0_rknd) then
                    iflag=-32
                    return
                endif
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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.and.list(2,i)==0) cycle
            if(list(1,i)==0.or.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
                if(list(1,j3)==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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine bdychk(ibndry,nvf,nbf,vx,vy,sf,nrl,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(2,15) :: values
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(10) :: rl
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,2+nrl
                    values(1,k)=0.0e0_rknd
                    values(2,k)=0.0e0_rknd
                enddo
                call sxy(rl,theta,itag,values)
                xx=values(1,1)
                yy=values(2,1)
                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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sklchk(ntr,nvr,nbr,itnode,ibndry,
     +      vx,vy,sf,nrl,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
            real(kind=rknd), dimension(10) :: rl
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,nrl,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,nrl,rl,sxy)
        if(iflag/=0) return
c
c       now check each region
c
        call rgnchk(ntr,itnode,ibndry,vx,vy,sf,jb,iflag,nrl,rl,sxy)
        if(iflag/=0) return
c
c       check symmetry specifications
c
        call symtst(ntr,itnode,ibndry,vx,vy,sf,jb,diam,iflag,nrl,rl,sxy)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine rgnchk(ntr,itnode,ibndry,vx,vy,sf,jb,iflag,nrl,
     +      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(10) :: rl
            real(kind=rknd), dimension(20) :: x,y
            real(kind=rknd), dimension(2,15) :: 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,2+nrl
                    values(1,mm)=0.0e0_rknd
                    values(2,mm)=0.0e0_rknd
                enddo
                call sxy(rl,theta,itag,values)
                x(2)=values(1,1)
                y(2)=values(2,1)
            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,2+nrl
                            values(1,mm)=0.0e0_rknd
                            values(2,mm)=0.0e0_rknd
                        enddo
                        call sxy(rl,theta,itag,values)
                        x(m+2)=values(1,1)
                        y(m+2)=values(2,1)
                    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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine symtst(ntr,itnode,ibndry,vx,vy,sf,jb,diam,
     +      iflag,nrl,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,15) :: values
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(10) :: rl
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,2+nrl
                            values(1,m)=0.0e0_rknd
                            values(2,m)=0.0e0_rknd
                        enddo
                        theta=thi1+dti*real(k,rknd)
                        call sxy(rl,theta,itag,values)
                        xi=values(1,1)
                        yi=values(2,1)
c
                        do m=1,2+nrl
                            values(1,m)=0.0e0_rknd
                            values(2,m)=0.0e0_rknd
                        enddo
                        theta=thj1+dtj*real(k,rknd)
                        call sxy(rl,theta,jtag,values)
                        xj=values(1,1)
                        yj=values(2,1)
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine fixdg2(nvf,nbf,vx,vy,sf,ibndry,eps)
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(nbf) :: bmark
            integer(kind=iknd), dimension(nvf) :: vmark
            integer(kind=iknd), dimension(2*nbf+nvf) :: list,link
            integer(kind=iknd), dimension(3) :: iv
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(3) :: c
cy
c       look at all degree 2 vertices and eliminate
c       those with angle approximately equal to pi
c
        eps1=1.0e2_rknd*epsilon(1.0e0_rknd)
        do i=1,nvf
            vmark(i)=0
            link(i)=0
        enddo
        next=nvf+1
        do i=1,nbf
            do j=1,2
                ii=ibndry(j,i)
                list(next)=i
                link(next)=link(ii)
                link(ii)=next
                next=next+1
                vmark(ii)=vmark(ii)+1
            enddo
        enddo
c
   10   ichng=0
        do ied1=1,nbf
            if(ibndry(3,ied1)/=0) go to 30
            if(ibndry(1,ied1)==0) go to 30
            if(vmark(ibndry(1,ied1))<vmark(ibndry(2,ied1))) then
                i=ibndry(1,ied1)
                i1=ibndry(2,ied1)
            else
                i1=ibndry(1,ied1)
                i=ibndry(2,ied1)
            endif
c
c       this test limits things to degree 2
c
            if(vmark(i)/=2) go to 30
c
            inext=link(i)
            do im=1,vmark(i)-1
                ied2=list(inext)
                if(ied1==ied2) then
                    inext=link(inext)
                    ied2=list(inext)
                endif
                inext=link(inext)
                if(ibndry(3,ied2)/=0) go to 30
                if(ibndry(4,ied1)/=ibndry(4,ied2)) go to 30
                if(ibndry(7,ied1)/=ibndry(7,ied2)) go to 30
                i2=ibndry(1,ied2)+ibndry(2,ied2)-i
c
c       geometry
c
                aa=abs(geom(i1,i,i2,vx,vy))
                if(aa>eps) go to 30
c
c       make sure this isnt a triangle
c
                next=link(i2)
                do m=1,vmark(i2)
                    ii=list(next)
                    next=link(next)
                    if(ibndry(1,ii)==i1) go to 30
                    if(ibndry(2,ii)==i1) go to 30
                enddo
c
c       this makes sure edges wont cross
c
                if(aa>eps1) then
                    iv(1)=i1
                    iv(2)=i
                    iv(3)=i2
                    do m=1,nvf
                        if(m/=i1.and.m/=i2.and.
     +                      m/=i.and.vmark(m)>0) then
                            call bari(vx(m),vy(m),vx,vy,iv,c)
                            cmn=min(c(1),c(2),c(3))
                            cmx=max(c(1),c(2),c(3))
                            if(cmn>=-0.01e0_rknd.and.
     +                          cmx<=1.01e0_rknd) go to 30
                        endif
                    enddo
                endif
            enddo
c
c       fixup list for vertex i
c
            ichng=ichng+1
            next=link(i)
            iold=i
            do m=1,vmark(i)
                ied2=list(next)
                iold=next
                next=link(next)
                if(ibndry(1,ied2)==i) then
                    ibndry(1,ied2)=i1
                else
                    ibndry(2,ied2)=i1
                endif
            enddo
c
c       merge lists of i and i1
c
            link(iold)=link(i1)
            link(i1)=link(i)
            vmark(i1)=vmark(i1)+vmark(i)-2
            vmark(i)=0
            ibndry(1,ied1)=0
c
c       delete edge ied1 from the list (appears twice)
c
            iold=i1
            next=link(i1)
            do m=1,vmark(i1)+2
                ii=list(next)
                if(ii==ied1) then
                    link(iold)=link(next)
                else
                    iold=next
                endif
                next=link(next)
            enddo
   30       continue
        enddo
        if(ichng/=0) go to 10
c
c       clean up
c
        nbf0=nbf
        nvf0=nvf
        nbf=0
        do i=1,nvf
            vmark(i)=0
        enddo
        do i=1,nbf0
            if(ibndry(1,i)==0) cycle
            nbf=nbf+1
            do j=1,7
                ibndry(j,nbf)=ibndry(j,i)
            enddo
            do j=1,2
                vmark(ibndry(j,nbf))=1
                sf(j,nbf)=sf(j,i)
            enddo
            bmark(i)=nbf
        enddo
c
        nvf=0
        do i=1,nvf0
            if(vmark(i)==0) cycle
            nvf=nvf+1
            vx(nvf)=vx(i)
            vy(nvf)=vy(i)
            vmark(i)=nvf
        enddo
c
c       fix vertex numbers, linked edges
c
        do i=1,nbf
            ibndry(1,i)=vmark(ibndry(1,i))
            ibndry(2,i)=vmark(ibndry(2,i))
            if(ibndry(4,i)<0) ibndry(4,i)=-bmark(-ibndry(4,i))
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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
            real(kind=rknd), dimension(10) :: rl
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)
        nrl=ip(13)
        iprob=abs(ip(6))
        if(iprob==4) then
            do i=1,nrl
                rl(i)=rp(90+i)
            enddo
        else
            rl(1)=rp(1)
        endif
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,nrl,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,nrl,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,nrl,rl,sxy)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dvedge(ntf,nvf,nbf,len,maxv,maxb,vx,vy,
     +      sf,ibndry,itnode,iflag,nrl,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
            integer(kind=iknd), dimension(65) :: mark
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(65) :: x,y,fi
            real(kind=rknd), dimension(10) :: rl
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=0.2e0_rknd
c
c        orient boundary edges
c
        im=1
        do i=1,nvf
            list(1,i)=0
            list(2,i)=0
            if(vx(i)<vx(im)) then
                im=i
            else if(vx(i)==vx(im).and.vy(i)<vy(im)) then
                im=i
            endif
        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
                        iflag=-53
                        return
                    endif
                    list(2,k)=i
                endif
            enddo
        enddo
        r=1.0e0_rknd
    5   if(list(1,im)==0.or.list(2,im)==0) then
            iflag=-53
            return
        endif
        i1=list(1,im)
        i2=list(2,im)
        ibef=ibndry(1,i1)+ibndry(2,i1)-im
        iaft=ibndry(1,i2)+ibndry(2,i2)-im
        q=geom(ibef,im,iaft,vx,vy)
        ibsv1=ibndry(1,i1)
        ibsv2=ibndry(1,i2)
        if(q*r<0.0e0_rknd) then
            istart=i1
            iend=i2
            ibndry(1,i2)=iaft
            ibndry(2,i2)=im
            ibndry(1,i1)=im
            ibndry(2,i1)=ibef
        else
            istart=i2
            iend=i1
            ibndry(1,i1)=ibef
            ibndry(2,i1)=im
            ibndry(1,i2)=im
            ibndry(2,i2)=iaft
        endif
c
        if(ibndry(3,i1)<0.and.ibndry(1,i1)/=ibsv1) then
            sfsv=sf(1,i1)
            sf(1,i1)=sf(2,i1)
            sf(2,i1)=sfsv
        endif
        if(ibndry(3,i2)<0.and.ibndry(1,i2)/=ibsv2) then
            sfsv=sf(1,i2)
            sf(1,i2)=sf(2,i2)
            sf(2,i2)=sfsv
        endif
c
        list(1,im)=-list(1,im)
   10   im=ibndry(2,istart)
        if(list(1,im)<=0.or.list(2,im)<=0) then
            iflag=-53
            return
        endif
        i1=list(1,im)
        i2=list(2,im)
        list(1,im)=-list(1,im)
        if(i1==istart) then
            istart=i2
        else
            istart=i1
        endif
        if(ibndry(2,istart)==im) then
            ibndry(2,istart)=ibndry(1,istart)
            ibndry(1,istart)=im
            if(ibndry(3,istart)<0) then
                sfsv=sf(1,istart)
                sf(1,istart)=sf(2,istart)
                sf(2,istart)=sfsv
            endif
        endif
        if(istart/=iend) go to 10
c
c       remaining vertices are on the boundary holes
c
        r=-1.0e0_rknd
        im=0
        do i=1,nvf
            if(list(1,i)<=0) cycle
            if(im==0) then
                im=i
            else
                if(vx(i)<vx(im)) then
                    im=i
                else if(vx(i)==vx(im).and.vy(i)<vy(im)) then
                    im=i
                endif
            endif
        enddo
        if(im/=0) go to 5
c
c       divide user specified edges
c
        nbf0=nbf
        do i=1,nbf0
            list(1,i)=0
            list(2,i)=0
            if(ibndry(3,i)==0) cycle
            call arclen(i,ibndry,1_iknd,sf,vx,vy,alen,theta1,
     +          theta2,radius,num,x,y,fi,nrl,rl,sxy)
c
c       add new points on circular arc
c
            nvsave=nvf
            nbsave=nbf
            if(ibndry(3,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
                    do k=3,7
                        ibndry(k,nbf)=ibndry(k,i)
                    enddo
                    sf(1,nbf)=sf(1,i)
                    sf(2,nbf)=sf(2,i)
                enddo
                ibndry(2,nbf)=ibndry(2,i)
                ibndry(2,i)=nvsave+1
                list(1,i)=nbsave+1
                list(2,i)=nbf
            else
c
c       add new points on parametrized curves
c
                np=0
                mark(1)=1
                mark(num+1)=1
                do lev=1,lmax
                    inc=2**(lmax-lev)
                    do j=inc+1,num,2*inc
                        if(mark(j-inc)==0.or.mark(j+inc)==0) then
                            mark(j)=0
                        else
                           gg=geom(j+inc,j,j-inc,x,y)
                           if(abs(gg)<thrsh) then
                                mark(j)=0
                           else
                                mark(j)=1
                                np=np+1
                           endif
                        endif
                    enddo
                enddo
                if(np==0) cycle
                if(nvf+np>maxv) then
                    iflag=84
                    return
                endif
                if(nbf+np>maxb) then
                    iflag=86
                    return
                endif
                iold=i
                dt=(sf(2,i)-sf(1,i))/real(num,rknd)
                do j=2,num
                    if(mark(j)==0) cycle
                    nvf=nvf+1
                    vx(nvf)=x(j)
                    vy(nvf)=y(j)
                    nbf=nbf+1
                    ibndry(1,nbf)=nvf
                    ibndry(2,nbf)=ibndry(2,iold)
                    ibndry(2,iold)=nvf
                    do k=3,7
                        ibndry(k,nbf)=ibndry(k,i)
                    enddo
                    theta=sf(1,i)+dt*real(j-1,rknd)
                    sf(1,nbf)=theta
                    sf(2,nbf)=sf(2,iold)
                    sf(2,iold)=theta
                    iold=nbf
                enddo
                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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine fndsym(ntf,nvf,nbf,vx,vy,sf,ibndry,itnode,
     +      iflag,nrl,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(2,15) :: values
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(10) :: rl
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,nrl,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,nrl,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,2+nrl
                                        values(1,m)=0.0e0_rknd
                                        values(2,m)=0.0e0_rknd
                                    enddo
                                    theta=thi1+dti*real(k,rknd)
                                    call sxy(rl,theta,itag,values)
                                    xi=values(1,1)
                                    yi=values(2,1)
c
                                    do m=1,2+nrl
                                        values(1,m)=0.0e0_rknd
                                        values(2,m)=0.0e0_rknd
                                    enddo
                                    theta=thj1+dtj*real(k,rknd)
                                    call sxy(rl,theta,jtag,values)
                                    xj=values(1,1)
                                    yj=values(2,1)
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(j<j1) j=j2
                        enddo
c
c           we found a similar pair
c
                        if(inc==1) then
                            itnode(1,ns2)=jv1
                            itnode(2,ns2)=jpedge
                            itnode(3,ns2)=ns1
                        else
                            itnode(1,ns2)=jv1
                            itnode(2,ns2)=jmedge
                            itnode(3,ns2)=-ns1
                        endif
                        go to 90
   80               continue
                    enddo
                enddo
   90       continue
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine setval(ip)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(100) :: ip
            common /val0/k0,ku,kx,ky,kl
            common /val1/j0,ju,jl
            common /val2/m0,ml,mlb,mub,mic,mim,mil
            common /val3/kf,kf1,kf2,kad
            common /val4/jj0,jjs,jjl
cy
c       a1xy,a2xy,fxy,p1xy,p2xy
c
        nrl=ip(13)
c
        k0=1
        ku=2
        kx=3
        ky=4
        kl=5
c
c       gnxy
c
        j0=1
        ju=2
        jl=3
c
c       gdxy
c
        m0=1
        ml=2
        mlb=ml+nrl
        mub=mlb+nrl
        mic=mub+nrl
        mim=mic+1
        mil=mim+1
c
c       qxy
c
        kf=1
        kf1=2
        kf2=3
        kad=4
c
c       sxy
c
        jj0=1
        jjs=2
        jjl=3
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine clenja(ip,itnode,ibndry,itdof,len)
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) :: iords
            integer(kind=iknd), dimension(2,len) :: list
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), save, dimension(3,3) :: index
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       make list of boundary edges
c
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        ndf=ip(4)
        do i=1,nvf
            list(1,i)=0
            list(2,i)=0
        enddo
        do i=1,nbf
            if(ibndry(4,i)==0) cycle
            iv1=ibndry(1,i)
            iv2=ibndry(2,i)
            if(list(1,iv1)==0) then
                list(1,iv1)=iv2
            else
                list(2,iv1)=iv2
            endif
            if(list(1,iv2)==0) then
                list(1,iv2)=iv1
            else
                list(2,iv2)=iv1
            endif
        enddo
c
c       vertex -- vertex
c
        lenad=nvf
        lenaod=3*nvf
        lened=0
        leneod=0
        numt=0
        nume=0
c
        do i=1,ntf
            call locord(i,ndof,iord,iords,itdof)
c
c       element -- edge/vertex
c
            if(iord>2) 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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mg(n,nb,ispd,method,mxcg,ising,eps1,ja,a,d,
     +      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,d
            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,d,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,d,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 12.0 - - - june, 2016
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
            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+2
                jup(i)=jap(i)
            enddo
            do i=1,nb
                call csze(i,ja,jap,ibs,a,asz,amtx)
            enddo
        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
                    ss=usz(j1)/usz(k)
                    do jj=j1+1,j2
                        j=ju(jj)
                        if(mark(j)/=0) cycle
cc                      if(usz(jj)<=atol) cycle
                        if(ss*usz(jj)<=atol) 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)<ju(k+1)-1) then
                    indx(k)=indx(k)+1
                    j=ju(indx(k))
                    list(k)=list(j)
                    list(j)=k
                endif
                go to 20
            endif
            call dfac(ni,u(jup(i)),ispd)
c
            do jj=ju(i),ju(i+1)-1
                mark(ju(jj))=0
            enddo
c
            if(ju(i)<ju(i+1)) then
                j=ju(ju(i))
                list(i)=list(j)
                list(j)=i
                indx(i)=ju(i)
            endif
c
            if(itype==1) call csze(i,ju,jup,ibs,u,usz,umtx)
        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 12.0 - - - june, 2016
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), allocatable, dimension(:) :: temp,sl1
            real(kind=rknd), allocatable, dimension(:,:) :: 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
                allocate(sl1(ni))
                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
                deallocate(sl1)
            endif
        else
            if(ni==1) then
c
c       block i is size 1
c
                allocate(sl1(nk))
                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
                deallocate(sl1)
            else
c
c       the general case
c
c       solve with diagonal block of row k
c
                allocate(temp(ni),sl(nk,ni))
                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
                deallocate(temp,sl)
            endif
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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), allocatable, dimension(:) :: templ,
     +          tempu,sl1,su1
            real(kind=rknd), allocatable, dimension(:,:) :: 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
                allocate(sl1(ni),su1(ni))
                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
                deallocate(sl1,su1)
            endif
        else
            if(ni==1) then
c
c       block i is size 1
c
                allocate(sl1(nk),su1(nk))
                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
                deallocate(sl1,su1)
            else
c
c       the general case
c
c       solve with diagonal block of row k
c
                allocate(sl(nk,ni),su(nk,ni),templ(ni),tempu(ni))
                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
                deallocate(sl,su,templ,tempu)
            endif
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cscg(n,nb,ispd,method,mxcg,eps,epsi,ja,a,d,
     +      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,d
            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,d,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,d,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)<zscale**2) then
                qscale=tstpiv(n,bp,bz,pap,zaz,br,apr,azr)
                if(qscale<zscale*sqrt(abs(zaz))) go to  50
            endif
c
c       the case of a 1 x 1 pivot
c
            alpha=bp/pap
            do i=1,n
                dr(i)=dr(i)+alpha*pr(i)
                br(i)=br(i)-alpha*apr(i)
                pr(i)=zr(i)
                apr(i)=azr(i)
            enddo
c
c       convergence test
c
            rrnorm=rl2nrm(n,br)
            call hist1(ihist,itnum,rrnorm)
            relerr=rrnorm/brnorm
cc          write(6,*) itnum,relerr
            if(relerr<=eps) return
            if(relerr>epsi) go to 200
            bp=bz*(ss/rrnorm)**2
            ss=rrnorm
            if(bp==0.0e0_rknd) return
            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,d,u,uc,
     +          apr,br,ispd,method)
            bp=sl2ip(n,apr,br,ss)
            beta=bp/bz
            bp=bp*(ss/rrnorm)**2
            ss=rrnorm
            if(bp==0.0e0_rknd) return
            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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine csbcg(n,nb,ispd,method,mxcg,eps,epsi,ja,a,d,
     +      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,d
            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,d,u,uc,
     +      pr,br,ispd,method)
        call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,d,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,d,u,uc,
     +          zr,azr,ispd,method)
            call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,d,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)<zscale**2) then
                qscale=tstpiv(n,bp,bz,pap,zaz,br,apr,azr)
                if(qscale<zscale*sqrt(abs(zaz))) go to  50
            endif
c
c       the case of a 1 x 1 pivot
c
            alpha=bp/pap
            do i=1,n
                dr(i)=dr(i)+alpha*pr(i)
                br(i)=br(i)-alpha*apr(i)
                bl(i)=bl(i)-alpha*apl(i)
                pr(i)=zr(i)
                pl(i)=zl(i)
                apr(i)=azr(i)
                apl(i)=azl(i)
            enddo
c
c       convergence test
c
            rrnorm=rl2nrm(n,br)
cc          rlnorm=rl2nrm(n,bl)
            call hist1(ihist,itnum,rrnorm)
            relerr=rrnorm/brnorm
cc          write(6,*) itnum,relerr
            if(relerr<=eps) return
            if(relerr>epsi) go to 200
            bp=bz*(ss/rrnorm)**2
            ss=rrnorm
            if(bp==0.0e0_rknd) return
            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,d,u,uc,
     +          apr,br,ispd,method)
            call hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,d,u,uc,
     +          apl,bl,jspd,method)
            bp=sl2ip(n,apl,br,ss)
            beta=bp/bz
            bp=bp*(ss/rrnorm)**2
            ss=rrnorm
            if(bp==0.0e0_rknd) return
            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 12.0 - - - june, 2016
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)<qmax) then
                qscale=qscale+(dq/qmax)**2
            else if(dq/=0.0e0_rknd) then
                qscale=1.0e0_rknd+qscale*(qmax/dq)**2
                qmax=abs(dq)
            endif
        enddo
        tstpiv=sqrt(qscale)*qmax
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine hbslv(n,nb,ja,jp,ibs,ibp,ibo,ju,juc,a,d,u,uc,
     +      x,b,ispd,method)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ja,ibs,ibp,jp,ibo,juc,ju
            real(kind=rknd), dimension(*) :: a,x,b,uc,u,d
            real(kind=rknd), dimension(n) :: y,r
            real(kind=rknd), dimension(nb) :: yc,rc
c
cy
c       ispd = 1   symmetric
c            = 0   non-symmetric
c            =-1   non-symmetric for a-transpose
c
c       two-level
c
        if(method==0) then
c
c       smoothing
c
            call sgsblu(n,nb,ja,ibs,ibp,a,d,x,b,ispd)
c
c       update residual
c
            call mtxmlt(n,nb,ja,ibs,ibp,a,x,r,ispd)
            do i=1,n
                r(i)=b(i)-r(i)
            enddo
c
c       coarse grid correction
c
            call fn2cr(nb,ibs,ibp,ibo,jp,r,rc)
            call snsilu(nb,juc,uc,yc,rc,ispd)
            call cr2fn(n,nb,ibs,ibp,ibo,jp,y,yc)
            do i=1,n
                x(i)=x(i)+y(i)
            enddo
c
c       update residual
c
            call mtxmlt(n,nb,ja,ibs,ibp,a,x,r,ispd)
            do i=1,n
                r(i)=b(i)-r(i)
            enddo
c
c       smoothing
c
            call sgsblu(n,nb,ja,ibs,ibp,a,d,y,r,ispd)
            do i=1,n
                x(i)=x(i)+y(i)
            enddo
c
c       stand-alone smoothers
c
        else if(method==1) then
            call snsblu(n,nb,ju,ibs,ibp,u,x,b,ispd)
        else
            call sgsblu(n,nb,ja,ibs,ibp,a,d,x,b,ispd)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine snsblu(n,nb,ju,ibs,ibp,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,ibs,ibp
            integer(kind=iknd) :: lmtx,umtx
            integer(kind=iknd), allocatable, dimension(:) :: jup
            real(kind=rknd), dimension(*) :: u,x,b
            real(kind=rknd), dimension(n) :: t
cy
c       ispd = 1   symmetric
c            = 0   non-symmetric
c            =-1   non-symmetric for a-transpose
c
c       solve a*x=b
c
        lenju=ju(nb+1)
        allocate(jup(lenju))
        call cjap(nb,ispd,ju,jup,ibs)
c
        lmtx=0
        umtx=0
        if(ispd==0) lmtx=jup(ju(nb+1))-jup(ju(1))
        if(ispd==-1) umtx=jup(ju(nb+1))-jup(ju(1))
c
        do i=1,n
            x(i)=b(i)
        enddo
c
c       lower triangular system
c
        do i=1,nb
            ni=ibs(i)
            iv=ibp(i)
c
c       solve diagonal block
c
            call dsolve(ni,u(jup(i)),x(iv),ispd)
c
c       multiply by lower triangle blocks
c
            do jj=ju(i),ju(i+1)-1
                j=ju(jj)
                nj=ibs(j)
                jv=ibp(j)
                call umult(ni,nj,x(jv),x(iv),u(jup(jj)+lmtx),0_iknd)
            enddo
        enddo
c
c       upper triangular system
c
        do i=nb,1,-1
            ni=ibs(i)
            iv=ibp(i)
            do k=1,ni
                t(k)=0.0e0_rknd
            enddo
c
c       multiply by upper trangle blocks
c
            do jj=ju(i),ju(i+1)-1
                j=ju(jj)
                nj=ibs(j)
                jv=ibp(j)
                call umult(ni,nj,t,x(jv),u(jup(jj)+umtx),1_iknd)
            enddo
c
c       solve diagonal block
c
            call dsolve(ni,u(jup(i)),t,ispd)
            do ii=1,ni
                x(iv+ii-1)=x(iv+ii-1)+t(ii)
            enddo
        enddo
c
        deallocate(jup)
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sgsblu(n,nb,ja,ibs,ibp,a,d,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
            integer(kind=iknd) :: lmtx,umtx
            integer(kind=iknd), allocatable, dimension(:) :: jap
            real(kind=rknd), dimension(*) :: a,x,b,d
            real(kind=rknd), dimension(n) :: t
cy
c       ispd = 1   symmetric
c            = 0   non-symmetric
c            =-1   non-symmetric for a-transpose
c
c       block symmetric gauss seidel
c
        lenja=ja(nb+1)
        allocate(jap(lenja))
        call cjap(nb,ispd,ja,jap,ibs)
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
        do i=1,n
            x(i)=b(i)
        enddo
c
c       lower triangular system
c
        do i=1,nb
            ni=ibs(i)
            iv=ibp(i)
c
c       solve diagonal block
c
            call dsolve(ni,d(jap(i)),x(iv),ispd)
c
c       multiply by lower triangle blocks
c
            do jj=ja(i),ja(i+1)-1
                j=ja(jj)
                nj=ibs(j)
                jv=ibp(j)
                call umult(ni,nj,x(jv),x(iv),a(jap(jj)+lmtx),0_iknd)
            enddo
        enddo
c
c       upper triangular system
c
        do i=nb,1,-1
            ni=ibs(i)
            iv=ibp(i)
            do k=1,ni
                t(k)=0.0e0_rknd
            enddo
c
c       multiply by upper trangle blocks
c
            do jj=ja(i),ja(i+1)-1
                j=ja(jj)
                nj=ibs(j)
                jv=ibp(j)
                call umult(ni,nj,t,x(jv),a(jap(jj)+umtx),1_iknd)
            enddo
c
c       solve diagonal block
c
            call dsolve(ni,d(jap(i)),t,ispd)
            do ii=1,ni
                x(iv+ii-1)=x(iv+ii-1)+t(ii)
            enddo
        enddo
c
        deallocate(jap)
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mtxmlt(n,nb,ja,ibs,ibp,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,ibs,ibp
            integer(kind=iknd) :: umtx,lmtx,lshift,ushift
            integer(kind=iknd), allocatable, dimension(:) :: jap
            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
        lenja=ja(nb+1)
        allocate(jap(lenja))
        call cjap(nb,ispd,ja,jap,ibs)
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
        do i=1,n
            b(i)=0.0e0_rknd
        enddo
c
        do i=1,nb
            ni=ibs(i)
            iv=ibp(i)-1
c
c       diagonal block
c
            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
                k=jap(i)+ni
                do ii=1,ni
                    b(iv+ii)=b(iv+ii)+a(jap(i)+ii-1)*x(iv+ii)
                    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
c
c       off diagonal blocks
c
            do jj=ja(i),ja(i+1)-1
                j=ja(jj)
                jv=ibp(j)-1
                do mm=1,ibs(j)
                    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
        deallocate(jap)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dfac(n,u,ispd)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: u
cy
c       factor a=ldu
c
        if(n==1) return
        ishift=0
        if(ispd/=1) ishift=((n-1)*n)/2
c
        ir=n+1
        do i=1,n-1
            jr=ir+n-i-1
            do j=i+1,n
                sl=u(ir+ishift)/u(i)
                su=u(ir)/u(i)
                u(j)=u(j)-sl*u(ir)
                kr=ir
                do k=j+1,n
                   jr=jr+1
                   kr=kr+1
                   u(jr)=u(jr)-sl*u(kr)
                   if(ispd==1) cycle
                   u(jr+ishift)=u(jr+ishift)-su*u(kr+ishift)
               enddo
               ir=ir+1
           enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dsolve(n,u,x,ispd)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd) :: lshift,ushift
            real(kind=rknd), dimension(*) :: u,x
cy
c       ispd = 1   symmetric
c            = 0   non-symmetric
c            =-1   non-symmetric for a-transpose
c
c       solve a*x=b
c
        if(n==1) then
            x(1)=x(1)/u(1)
            return
        endif
        lshift=0
        ushift=0
        if(ispd==0) lshift=((n-1)*n)/2
        if(ispd==-1) ushift=((n-1)*n)/2
c
        ir=n+1+lshift
        do ii=1,n
            x(ii)=x(ii)/u(ii)
            do jj=ii+1,n
                x(jj)=x(jj)-u(ir)*x(ii)
                ir=ir+1
            enddo
        enddo
        ir=ir-1+ushift-lshift
        do ii=n,1,-1
            s=0.0e0_rknd
            do jj=n,ii+1,-1
                s=s+u(ir)*x(jj)
                ir=ir-1
            enddo
            x(ii)=x(ii)-s/u(ii)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dmlt(n,a,x,b,ispd)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd) :: lshift,ushift
            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       form b=a*x
c
        do i=1,n
            b(i)=a(i)*x(i)
        enddo
        if(n==1) return
c
        lshift=0
        ushift=0
        if(ispd==0) lshift=((n-1)*n)/2
        if(ispd==-1) ushift=((n-1)*n)/2
c
        ir=n+1
        do i=1,n
            do j=i+1,n
                b(i)=b(i)+a(ir+ushift)*x(j)
                b(j)=b(j)+a(ir+lshift)*x(i)
                ir=ir+1
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine umult(n,m,x,y,u,isw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y,u
cy
c
c       multiply by off diagonal block x <- x-u*y
c
        if(isw==0) then
            do mm=1,m
                ks=(mm-1)*n
                s=0.0e0_rknd
                do ii=1,n
                    s=s+u(ks+ii)*y(ii)
                enddo
                x(mm)=x(mm)-s
            enddo
        else
            do mm=1,m
                ks=(mm-1)*n
                do ii=1,n
                    x(ii)=x(ii)-u(ks+ii)*y(mm)
                enddo
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cjap(nb,ispd,ja,jap,ibs)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ja,jap,ibs
cy
c
c       compute jap
c
        jnext=1
        if(ispd==1) then
            do i=1,nb
                jap(i)=jnext
                jnext=jnext+(ibs(i)*(ibs(i)+1))/2
            enddo
        else
            do i=1,nb
                jap(i)=jnext
                jnext=jnext+ibs(i)**2
            enddo
        endif
        jap(nb+1)=jnext
        do i=1,nb
            do jj=ja(i),ja(i+1)-1
                j=ja(jj)
                jap(jj)=jnext
                jnext=jnext+ibs(i)*ibs(j)
            enddo
        enddo
        jap(ja(nb+1))=jnext
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ja2ja(nb,nptr,lenja,ja,ibs,ibp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ja,ibs,ibp,nptr
            integer(kind=iknd), dimension(lenja) :: ja0
            integer(kind=iknd), dimension(nb) :: ibs0,ibp0,q
cy
c       static condenstaion  part
c
        nsc=nptr(2)-1
        do i=1,lenja
            ja0(i)=ja(i)
        enddo
c
c       this loop gives element dofs degree 0 so they are ordered first
c
        do i=1,nsc
            ja0(i)=ja(nsc+1)
        enddo
c
c       min deg ordering
c
        call md(nb,lenja,ja0,q,lenu0)
c
        do i=1,lenja
            ja0(i)=ja(i)
        enddo
        do i=1,nb
            ibs0(i)=ibs(i)
            ibp0(i)=ibp(i)
            ja(i+1)=0
        enddo
c
        do i=1,nb
            iq=q(i)
c
c       block arrays
c
            ibs(iq)=ibs0(i)
            ibp(iq)=ibp0(i)
c
c       ja pointers
c
            do jj=ja0(i),ja0(i+1)-1
                j=ja0(jj)
                jq=q(j)
                if(jq>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 12.0 - - - june, 2016
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<len) then
                    if(list(kson)<list(kson+1)) kson=kson+1
                endif
                if(list(k)>=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<n-1) then
                    if(list(kson)<list(kson+1)) kson=kson+1
                endif
                if(list(k)>=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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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(i<j) then
            imin=ja(i)
            imax=ja(i+1)-1
   10       imid=(imin+imax)/2
            if(ja(imid)==j) then
                indx=imid
                ij=jap(indx)
                ji=ij+amtx
                return
            else if(imid==imax) then
                indx=0
                ij=0
                ji=0
                return
            else if(ja(imid)<j) then
                if(imid==imin) imid=imax
                imin=imid
                go to 10
            else
                imax=imid
                go to 10
            endif
c
        else
            jmin=ja(j)
            jmax=ja(j+1)-1
   20       jmid=(jmin+jmax)/2
            if(ja(jmid)==i) then
                indx=jmid
                ji=jap(indx)
                ij=ji+amtx
                return
            else if(jmid==jmax) then
                indx=0
                ij=0
                ji=0
                return
            else if(ja(jmid)<i) then
                if(jmid==jmin) jmid=jmax
                jmin=jmid
                go to 20
            else
                jmax=jmid
                go to 20
            endif
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine jamap(i,j,ijs,ij,ji,indx,ja,js,jns,amtx)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ja,js,jns
            integer(kind=iknd) :: amtx
cy
c       compute location of a(i,j) and a(j,i)
c
        if(i<j) then
            do ii=ja(i),ja(i+1)-1
                if(ja(ii)==j) then
                    indx=ii
                    ijs=js(indx)
                    ij=jns(indx)
                    ji=ij+amtx
                    return
                endif
            enddo
c
        else
            do jj=ja(j),ja(j+1)-1
                if(ja(jj)==i) then
                    indx=jj
                    ijs=js(indx)
                    ji=jns(indx)
                    ij=ji+amtx
                    return
                endif
            enddo
        endif
        ijs=0
        ij=0
        ji=0
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine jamap0(i,j,ij,ji,ja,amtx)
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) :: amtx
cy
c       compute location of a(i,j) and a(j,i)
c
        if(i<j) then
            do ij=ja(i),ja(i+1)-1
                if(ja(ij)==j) then
                    ji=ij+amtx
                    return
                endif
            enddo
c
        else
            do ji=ja(j),ja(j+1)-1
                if(ja(ji)==i) then
                    ij=ji+amtx
                    return
                endif
            enddo
        endif
        ij=0
        ji=0
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine md(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,befor,after
            integer(kind=iknd), dimension(n) :: list
            integer(kind=iknd), dimension(2*lenja-n) :: jc
cy
c
c       minimum degree algorithm
c
c       list        = linked list of equivalent vertices (v,e)
c                   = (temp) ptr to equiv vertex with clique imin (c)
c       equiv       = number of equivalent vertices (v)
c                   = ptr to equivant vertex (e)
c                   = size of clique (c)
c       befor/after = doubly linked list of verts. by degree (v)
c                     (temp) nvert/ncliq for verts in imin
c                     (temp) marker for outmatched verts in imin
c                   = (temp) switch/intersection size with imin (c)
c       mark        = temp linked list
c       p           = order (tail is head ptrs into befor/after)
c
        lenu=n+1
        mndeg=n+1
        iempty=0
        next=1
        do i=1,n
            p(i)=0
            equiv(i)=1
            list(i)=i
            befor(i)=0
            after(i)=0
            mark(i)=0
        enddo
        call ja2jc(n,ja,jc)
        do i=1,n
            ideg=jc(i+1)-jc(i)
            if(ideg<=0) then
                p(next)=i
                next=next+1
            else
                id=n+1-ideg
                if(p(id)/=0) befor(p(id))=i
                after(i)=p(id)
                p(id)=i
                befor(i)=-id
                mndeg=min(mndeg,ideg)
            endif
        enddo
        if(next>n) 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,mark,equiv,ilen,imndeg,iempty)
c
        numequ=equiv(imin)
        i=imin
        do ii=1,numequ
            p(next)=i
            next=next+1
            equiv(i)=0
            lenu=lenu+imndeg+numequ-ii
            i=list(i)
        enddo
        if(next>n) go to 100
c
c       if the fillin will create a dense matrix....
c
        if(next+imndeg>n) then
            i=imin
            numequ=0
            do ii=1,ilen
                i=mark(i)
                inum=equiv(i)
                m=i
                do mm=1,inum
                    p(next)=m
                    next=next+1
                    equiv(m)=0
                    numequ=numequ+1
                    lenu=lenu+imndeg-numequ
                    m=list(m)
                enddo
            enddo
            go to 100
        endif
c
c       eliminate redundant vertices from adjacency lists of clique
c       members...this allows simple elimination of equivalent vertices
c
        i=imin
        numequ=0
        jx=imin
        jlen=0
        do ii=1,ilen
            i=mark(i)
            if(after(i)>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,befor,after,
     +          nvert,ncliq,ideg)
c
c       test for equivalence
c
            if(nvert==0.and.ncliq==1) then
                inum=equiv(i)
                m=i
                do mm=1,inum
                    p(next)=m
                    next=next+1
                    equiv(m)=0
                    numequ=numequ+1
                    lenu=lenu+imndeg-numequ
                    m=list(m)
                enddo
            endif
c
c       look for equivalent vertices
c
            if(nvert==0.and.ncliq==2) then
                jcj=-jc(jc(i))
                if(mark(jcj)==0) then
                    mark(jcj)=jx
                    jx=jcj
                    jlen=jlen+1
                    list(jcj)=i
                else
                    ieq=list(jcj)
                    inum=equiv(i)
                    equiv(ieq)=equiv(ieq)+inum
                    m=list(i)
                    do mm=1,inum
                        mnext=list(m)
                        list(m)=list(ieq)
                        list(ieq)=m
                        equiv(m)=-ieq
                        m=mnext
                    enddo
                endif
            endif
c
c       save partial degree (imin is not counted yet)
c
            if(equiv(i)>0) after(i)=ideg
        enddo
        if(next>n) go to 100
c
c       update degrees
c
        equiv(imin)=imndeg-numequ
        i=imin
        do ii=1,ilen
            i=mark(i)
            if(equiv(i)<=0) cycle
c
c       overcounting with three cliques requires this
c
            id=n+1-min(after(i)+equiv(imin)-1,n-next)
            if(p(id)/=0) befor(p(id))=i
            after(i)=p(id)
            p(id)=i
            befor(i)=-id
        enddo
c
c       clean up  mark, move clique to jc
c
        call svcliq(imin,jc,mark,equiv,ilen,iempty)
c
c     update cliques
c
        do jj=1,jlen
            jnext=mark(jx)
            call clqupd(jx,jc,mark,equiv,iempty)
            jx=jnext
        enddo
c
        mndeg=max(1,equiv(imin))
        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
c
c       reversing order is specific to bank/smith bordering algorithm
c
cc      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
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mkcliq(imin,jc,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
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           equiv(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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine jcupdt(imin,i,jc,mark,equiv,befor,after,nvert,
     +      ncliq,ideg)
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,after
cy
c       update jc for vertex i
c
        iptr=jc(i)
        nvert=0
        ncliq=1
        ideg=0
        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
                    ideg=ideg+equiv(jcj)
                endif
            else
c
c       this loop overestimates degrees for vertices
c       connected to three or more cliques
c       on the first encounter, compute the intersection
c
                if(equiv(jcj)<=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
                    ideg=ideg+after(jcj)
                endif
            endif
        enddo
        jc(iptr)=-imin
        if(iptr+1<jc(i+1)) jc(iptr+1)=0
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine clqupd(imin,jc,mark,equiv,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
cy
c       delete equivalent vertices from clique list
c
        jcj=imin
        jcnext=jc(jcj)
        jclast=jc(jcj+1)-1
   10   jcur=jc(jcj)
        jend=jc(jcj+1)-1
   20   jcj=abs(jc(jcur))
        if(jcj==0) go to 40
        if(jc(jcur)<0) then
            equiv(jcj)=0
            mark(jcj)=iempty
            iempty=jcj
            go to 10
        endif
        if(equiv(jcj)>0) then
            if(jcnext>jclast) then
                locsv=jclast
   30           if(mark(iempty)==0) then
                    next=iempty
                    iempty=mark(next)
                else
                    next=mark(iempty)
                    mark(iempty)=mark(next)
                endif
                jcnext=jc(next)+1
                jclast=jc(next+1)-1
                if(jcnext>jclast) go to 30
                jc(jcnext-1)=jc(locsv)
                jc(locsv)=-next
            endif
c
            jc(jcnext)=jcj
            jcnext=jcnext+1
        endif
        jcur=jcur+1
        if(jcur<=jend) go to 20
   40   if(jcnext<=jclast) jc(jcnext)=0
        mark(imin)=0
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine svcliq(imin,jc,mark,equiv,ilen,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
cy
c       save clique imin in jc
c
        jcnext=jc(imin)
        jclast=jc(imin+1)-1
        i=imin
        do ii=1,ilen
            is=i
            i=mark(i)
            mark(is)=0
            if(equiv(i)<=0) cycle
c
c       pop the stack if necessary
c
            if(jcnext>jclast) then
                locsv=jclast
   10           next=iempty
                iempty=mark(next)
                jcnext=jc(next)+1
                jclast=jc(next+1)-1
                if(jcnext>jclast) go to 10
                jc(jcnext-1)=jc(locsv)
                jc(locsv)=-next
            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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine blk3(ndf,ip,rp,vx,vy,itdof,itnode,du,dum,ja,ibs,
     +      ibp,ibo,a,da,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,da
            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,da,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,da,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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine blk4(ndf,nrl,ip,du,dum,duc,ja,ibs,ibp,ibo,a,da,
     +      jua,ua,juac,jp,uac,h,g,maxsu,su,b,p,dl,rd,maxd,udot,
     1      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(ndf,*) :: rd
            real(kind=rknd), dimension(ndf,nrl) :: hsu
            real(kind=rknd), dimension(maxsu,*) :: su
            real(kind=rknd), dimension(maxd,*) :: udot
            real(kind=rknd), dimension(*) :: a,h,b,p,ua,uac,g,
     +          du,dum,duc,dl,da
            real(kind=rknd), dimension(ndf) :: hdu
            real(kind=rknd), dimension(nrl) :: gl
            real(kind=rknd), dimension(200) :: t
            real(kind=rknd), dimension(nrl*nrl) :: gs
cy
        newndf=ip(30)
        ndd=ip(33)
        nb=ip(91)
        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,da,jua,ua,juac,jp,uac,ibs,ibp,ibo,
     1      du,b,reler1,jflag,7_iknd)
        if(jflag/=0) return
        call mtxmlt(ndf,nb,ja,ibs,ibp,h,du,hdu,1_iknd)
        do i=1,ndf
            hdu(i)=p(i)-hdu(i)
        enddo
c
c       second group of solves, update udot
c
        do k=1,nrl
            call mg(ndf,nb,ispd,method,mxcg,ising,epsmg,ja,
     +          a,da,jua,ua,juac,jp,uac,ibs,ibp,ibo,
     1          dum,rd(1,k),reler2,jflag,8_iknd)
            if(jflag/=0) return
c
            do i=1,ndf
                udot(i,k)=udot(i,k)+dum(i)
            enddo
c
            call mtxmlt(ndf,nb,ja,ibs,ibp,h,udot(1,k),
     +          hsu(1,k),1_iknd)
            if(isw==1) then
                do i=1,ndd
                    hsu(i,k)=su(i,k)+su(ndf+i,k)-hsu(i,k)
                enddo
                do i=ndd+1,ndf
                    hsu(i,k)=su(i,k)-hsu(i,k)
                enddo
            else
                do i=1,ndf
                    hsu(i,k)=su(i,k)-hsu(i,k)
                enddo
            endif
        enddo
c
c       schur complement
c
        if(isw==1) then
            k=1
            do i=1,nrl
                t(k)=rl2ip(newndf,su(1,i),udot(1,i))
                t(k+1)=rl2ip(newndf,udot(1,i),hsu(1,i))
                t(k+2)=rl2ip(newndf,su(1,i),du)
                t(k+3)=rl2ip(newndf,udot(1,i),hdu)
                k=k+4
                do j=i+1,nrl
                    t(k)=rl2ip(newndf,su(1,i),udot(1,j))
                    t(k+1)=rl2ip(newndf,udot(1,i),hsu(1,j))
                    k=k+2
                enddo
            enddo
            len=k-1
            call pl2ip(t,len)
            nn=nrl+1
            k=1
            do i=1,nrl
                gs(i)=g(i)-t(k)-t(k+1)
                gl(i)=dl(i)-t(k+2)-t(k+3)
                k=k+4
                do j=i+1,nrl
                    gs(nn)=g(nn)-t(k)-t(k+1)
                    k=k+2
                    nn=nn+1
                enddo
            enddo
        else
            nn=nrl+1
            do i=1,nrl
                q1=rl2ip(ndf,su(1,i),udot(1,i))
                q2=rl2ip(ndf,udot(1,i),hsu(1,i))
                gs(i)=g(i)-q1-q2
                q1=rl2ip(ndf,su(1,i),du)
                q2=rl2ip(ndf,udot(1,i),hdu)
                gl(i)=dl(i)-q1-q2
                do j=i+1,nrl
                    q1=rl2ip(ndf,su(1,i),udot(1,j))
                    q2=rl2ip(ndf,udot(1,i),hsu(1,j))
                    gs(nn)=g(nn)-q1-q2
                    nn=nn+1
                enddo
            enddo
        endif
c
c       factor and solve schur complement block
c
        call dfac(nrl,gs,1_iknd)
        do i=1,nrl
            duc(i)=gl(i)
        enddo
        call dsolve(nrl,gs,duc,1_iknd)
c
c       right hand sides
c
        do i=1,ndf
            q1=0.0e0_rknd
            q2=0.0e0_rknd
            do j=1,nrl
                q1=q1+udot(i,j)*duc(j)
                q2=q2+hsu(i,j)*duc(j)
            enddo
            du(i)=du(i)-q1
            hdu(i)=hdu(i)-q2
        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,da,jua,ua,juac,jp,uac,ibs,ibp,ibo,
     1      dum,hdu,reler3,jflag,9_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine blk5(n,ip,eps1,ja,ibs,ibp,ibo,a,h,g,
     +      su,sm,jua,ua,juac,jp,uac,jug,ug,da,dg,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,da,dg
            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,da,jua,ua,juac,
     +      jp,uac,h,g,dg,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,da,jua,ua,juac,
     +          jp,uac,h,g,dg,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)*rnorm<zscale) then
                qscale=tstpiv(n3,bp,bz,pap,zaz,b,ap,az)
                if(qscale<abs(zscale*zaz)) go to  50
            endif
c
c       the case of a 1 x 1 pivot
c
            alpha=bp/pap
            bp=bz
            do i=1,n
                du(i)=du(i)+alpha*p(m1+i-1)
                dum(i)=dum(i)+alpha*p(m2+i-1)
                duc(i)=duc(i)+alpha*p(m3+i-1)
            enddo
            do i=1,n3
                b(i)=b(i)-alpha*ap(i)
                p(i)=z(i)
                ap(i)=az(i)
            enddo
c
c       convergence test
c
            rnorm=rl2nrm(n3,b)
            call hist1(ihist,itnum,rnorm)
            relerr=rnorm/bnorm
cc          write(6,*) itnum,relerr
            if(relerr<=eps.or.bp==0.0e0_rknd) return
            if(relerr>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
                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,da,jua,ua,juac,
     +          jp,uac,h,g,dg,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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine solve5(ndf,ip,ja,ibs,ibp,ibo,a,da,jua,ua,
     +      juac,jp,uac,h,g,dg,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,da,dg
            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,da,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,da,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,dg,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,da,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,da,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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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), save, dimension(100) :: um
            real(kind=rknd), dimension(10) :: rl,rl0
cy
            external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy
            data um/100*0.0e0_rknd/
c
c       compute the step size for the next continuation step
c
        nbf=ip(3)
        iprob=ip(6)
        ispd=ip(8)
        nrl=ip(13)
c
        bias=100.0e0_rknd
        ratmax=25.0e0_rknd
        step=0.25e0_rknd
        sh=rp(45)
        rl0dot=rp(33)
        rl0(1)=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(1)=rl0(1)+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,um,
     +          um,um,u0,u0,u0,nrl,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,um,nrl,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,um,nrl,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(1)-rl0(1))-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(1))*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 12.0 - - - june, 2016
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(ndf) :: mark
            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,btm
            real(kind=rknd), dimension(100,100) :: a,azr,atm,azp,gtm,htm
            real(kind=rknd), dimension(10) :: rl,rrl
            real(kind=rknd), save, dimension(100) :: utm
cy
            external a1xy,a2xy,fxy,gnxy,gdxy,p1xy,p2xy,sxy
            data utm/100*0.0e0_rknd/
c
c        initialize
c
        nrl=1
        rl(1)=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(1)=rl(1)+delta
        do i=1,ntf
c
c       compute element stiffness matrix
c
            call eleasm(i,itnode,ibndry,itdof,vx,vy,sf,u,utm,
     +          utm,vx,vy,u,u,u,nrl,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,vx,vy,zr,u,u,nrl,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,vx,vy,zp,u,u,nrl,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,vx,vy,u,u,u,nrl,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,utm,nrl,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,utm,nrl,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,utm,nrl,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,utm,nrl,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,utm,nrl,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,utm,nrl,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)*zrnorm<abs(zrd)*zpnorm) ibrch=1
            else
                if(zrnorm<zpnorm) ibrch=1
            endif
        endif
c
c       compute udot and lambda dot
c
        if(ibrch==1) then
            rldot=1.0e0_rknd/sqrt(zpnorm**2+1.0e0_rknd)
            do i=1,ndf
                udot(i)=zp(i)
            enddo
        else
            rldot=1.0e0_rknd/sqrt(zrnorm**2+1.0e0_rknd)
            do i=1,ndf
                udot(i)=zr(i)
            enddo
        endif
        rdot=(drdrl+rl2ip(ndf,p,udot))*rldot/2.0e0_rknd
        im=0
        if(isw==1) then
            if(rp(33)*rldot<0) im=1
        else
            if(rp(33)*rdot-rp(34)*rldot<0.0e0_rknd) im=1
        endif
        if(im==1) then
            rldot=-rldot
            rdot=-rdot
        endif
        rp(23)=rldot
        rp(24)=rdot
c
c       set dirichlet boundary conditions
c
        call cdbc(ndf,nbf,itdof,ibndry,ibedge,mark)
        do i=1,ndf
            if(mark(i)/=0) udot(i)=0.0e0_rknd
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine evinit(ndf,ip,evl,evr,itdof,ibndry,ibedge)
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
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(ndf) :: mark
            real(kind=rknd), dimension(*) :: evl,evr
cy
c       initialize left and right singular vectors
c
        ndf=ip(4)
        nbf=ip(3)
c
c       check for null vectors
c
        evrn=rl2nrm(ndf,evr)
        evln=rl2nrm(ndf,evl)
        if(evrn==0.0e0_rknd.or.evln==0.0e0_rknd) then
            call cdbc(ndf,nbf,itdof,ibndry,ibedge,mark)
            do i=1,ndf
                evr(i)=1.0e0_rknd
                evl(i)=1.0e0_rknd
                if(mark(i)==1) then
                    evr(i)=0.0e0_rknd
                    evl(i)=0.0e0_rknd
                endif
            enddo
            evrn=rl2nrm(ndf,evr)
            evln=rl2nrm(ndf,evl)
        endif
c
        if(evrn==0.0e0_rknd.or.evln==0.0e0_rknd) return
c
c       normalize initial vectors
c
        dp=rl2ip(ndf,evl,evr)
        if(dp<0.0e0_rknd) evln=-evln
        do i=1,ndf
            ee=evr(i)/evrn
            evl(i)=evl(i)/evln
            evr(i)=ee
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine bdinit(ntf,ndf,ip,rp,u,vx,vy,sf,itdof,
     +      itnode,ibndry,ibedge,bdlwr,bdupr,gdxy,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(2,*) :: ibedge
            integer(kind=iknd), dimension(3) :: iords
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(3,ntf) :: icurv
            real(kind=rknd), dimension(*) :: u,bdlwr,bdupr,vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(50) :: g
            real(kind=rknd), dimension(100) :: rp,xp,yp
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(ndf) :: gm
cy
            external gdxy,sxy
c
c       compute bdupr, bdlwr
c
        iprob=abs(ip(6))
        nrl=ip(13)
        nbf=ip(3)
        rmu=rp(63)
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        tol=max(1.0e-2_rknd*rmu,eps)
        rl(1)=rp(21)
c
        if(iprob==4) then
            do i=1,nrl
                rl(i)=rp(90+i)
            enddo
            xx=0.0e0_rknd
            yy=0.0e0_rknd
            itag=0
            do m=1,3+4*nrl
                g(m)=0.0e0_rknd
            enddo
            call gdxy(xx,yy,rl,itag,g)
            do j=1,nrl
                bdlwr(j)=g(1+j+nrl)
                bdupr(j)=g(1+j+2*nrl)
                if(bdupr(j)/=0.0e0_rknd) then
                    bup=abs(bdupr(j))*tol
                else
                    bup=tol
                endif
                if(bdlwr(j)/=0.0e0_rknd) then
                    blw=abs(bdlwr(j))*tol
                else
                    blw=tol
                endif
                if(bdlwr(j)+blw<=bdupr(j)-bup) then
                    rl(j)=max(rl(j),bdlwr(j)+blw)
                    rl(j)=min(rl(j),bdupr(j)-bup)
                else if(bdlwr(j)>bdupr(j)) then
                    stop 5555
                else
                    rr=tol*(bdupr(j)-bdlwr(j))
                    rl(j)=max(rl(j),bdlwr(j)+rr)
                    rl(j)=min(rl(j),bdupr(j)-rr)
                endif
                rp(90+j)=rl(j)
            enddo
            return
        endif
c
        do i=1,ndf
            bdupr(i)=0.0e0_rknd
            bdlwr(i)=0.0e0_rknd
            gm(i)=0.0e0_rknd
        enddo
c
        call ccurv(ntf,nbf,ibndry,ibedge,icurv)
c
        do i=1,ntf
            call l2gmap(i,idof,ndof,iord,iords,itdof)
            call cnode2(i,itnode,ibndry,itdof,icurv,vx,vy,nrl,rl,
     +          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,3+4*nrl
                    g(m)=0.0e0_rknd
                enddo
                call gdxy(xx,yy,rl,itag,g)
                ivj=idof(j)
                gm(ivj)=gm(ivj)+area
                bdlwr(ivj)=bdlwr(ivj)+area*g(2+nrl)
                bdupr(ivj)=bdupr(ivj)+area*g(2+2*nrl)
             enddo
        enddo
c
        bup=0.0e0_rknd
        blw=0.0e0_rknd
        do i=1,ndf
            bdupr(i)=bdupr(i)/gm(i)
            bdlwr(i)=bdlwr(i)/gm(i)
            bup=max(abs(bdupr(i)),bup)
            blw=max(abs(bdlwr(i)),blw)
        enddo
        if(bup>0.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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine setbdl(nrl,rl,rp,g,dl,bdlwr,bdupr)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(*) :: g,bdlwr,bdupr,dl
cy
c       compute new diagonal and rhs for schur complement system
c
        rmu=rp(63)
        if(rmu<=0.0e0_rknd) return
        area=rp(80)
        rsh=rp(64)*rmu
c
        do i=1,nrl
            ru=0.0e0_rknd
            uu=0.0e0_rknd
            if(rl(i)>bdlwr(i)) then
                ru=ru+rmu/(rl(i)-bdlwr(i))
                uu=uu+rmu/(rl(i)-bdlwr(i))**2
            endif
            if(rl(i)<bdupr(i)) then
                ru=ru+rmu/(rl(i)-bdupr(i))
                uu=uu+rmu/(rl(i)-bdupr(i))**2
            endif
            dl(i)=dl(i)+(ru+rsh*rl(i))*area
            g(i)=g(i)+(uu+rsh)*area
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine gfinit(ip,maxd,gf,maxt,e)
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(maxd,*) :: gf
            real(kind=rknd), dimension(maxt,*) :: e
cy
c       initialize grid functions
c
        ntf=ip(1)
        ndf=ip(4)
        ngf=ip(77)
        do j=1,ngf
            do i=1,ndf
                gf(i,j)=0.0e0_rknd
            enddo
        enddo
        do j=1,2
            do i=1,ntf
                e(i,j)=0.0e0_rknd
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine uinit(ntf,ndf,ip,rp,itnode,ibndry,ibedge,
     +      vx,vy,sf,u,um,uc,itdof,gdxy,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(100) :: ip,idof
            integer(kind=iknd), dimension(3,ntf) :: icurv
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(2,*) :: ibedge
            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(ndf) :: gm
            real(kind=rknd), dimension(100) :: rp,xp,yp
            real(kind=rknd), dimension(50) :: g
            real(kind=rknd), dimension(10) :: rl
cy
            external gdxy,sxy
c
c       initialize u
c
        nrl=ip(13)
        nbf=ip(3)
        iprob=abs(ip(6))
        itask=ip(7)
c
c       check status of u initialization
c
        umax=0.0e0_rknd
        do i=1,ndf
            umax=max(umax,abs(u(i)))
        enddo
        if(umax>0.0e0_rknd) return
c
        call ccurv(ntf,nbf,ibndry,ibedge,icurv)
        if(iprob/=5) then
            do m=1,3+4*nrl
                g(m)=0.0e0_rknd
            enddo
            call gdxy(vx(1),vy(1),rl,itnode(5,1),g)
            if(iprob==4) then
                do i=1,nrl
                    rp(90+i)=g(3+3*nrl+i)
                    rl(i)=rp(90+i)
                enddo
                if(itask==8) call chksf(vx,vy,ibndry,sf,ip,rp,sxy)
            else
                rp(21)=g(4+3*nrl)
                rl(1)=rp(21)
            endif
        endif
        if(iprob==6) then
            rl(1)=rp(46)
            if(itask==10) rl(1)=rl(1)+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) 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,nrl,rl,
     +          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,3+4*nrl
                    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(2+3*nrl)
                if(iprob==4) then
                    um(ivj)=um(ivj)+area*g(3+3*nrl)
                else if(iprob==5) then
                    um(ivj)=um(ivj)+area*g(3+3*nrl)
                    uc(ivj)=uc(ivj)+area*g(4+3*nrl)
                endif
            enddo
        enddo
        do i=1,ndf
            u(i)=u(i)/gm(i)
        enddo
        if(iprob==4) 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 12.0 - - - june, 2016
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,nvdd0,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(2,*) :: ibedge
            integer(kind=iknd), dimension(6,*) :: ipath
            integer(kind=iknd), dimension(*) :: ja,ibs,ibp,ja0,ir0,map0
            integer(kind=iknd), dimension(ndf) :: mark,markb,map
            integer(kind=iknd) :: amtx0,smtx0,amtx
            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(*) :: vx,vy,a,h,g,su,sm,b,d,
     +          u,u0,udot,um,uc,vx0,vy0,p,dl,bdlwr,bdupr,rd,
     1          h0,g0,su0,sm0,a0
            real(kind=rknd), dimension(nvdd0,6) :: gf
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(100,100) :: fa,fh,fg,fsm,fsu
            real(kind=rknd), dimension(200) :: t
            real(kind=rknd), dimension(10) :: rl
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)
        nrl=ip(13)
        newndf=ip(30)
        ndd=ip(33)
        iprob=abs(ip(6))
        ispd=ip(8)
        itask=ip(7)
        nm=ja0(1)-2
        maxd=ip(85)
        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
            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(itask==8) call cmark4(nvf,nbf,ibndry,mark)
c
        rl(1)=rp(21)
        if(abs(iprob)==6) then
            rl(1)=rp(46)
            if(itask==10) rl(1)=rl(1)+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) then
            sh=rp(64)
            do i=1,ndf
                p(i)=0.0e0_rknd
            enddo
            do i=1,nrl
                rl(i)=rp(90+i)
                dl(i)=0.0e0_rknd
            enddo
            do i=1,(ndf+ndd)*nrl
                sm(i)=0.0e0_rknd
                su(i)=0.0e0_rknd
            enddo
            do i=1,nrl*nrl
                g(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(65)
            do i=1,ndf+ndd
                dl(i)=0.0e0_rknd
                p(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
            do i=1,ja0(nm+1)-1
                h0(i)=0.0e0_rknd
                g0(i)=0.0e0_rknd
            enddo
            smtx0=ja0(nm+1)-ja0(1)
            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,uc,nrl,rl,iprob,gdxy,sxy)
        enddo
c
        r=0.0e0_rknd
        drdrl=0.0e0_rknd
        scleqn=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,
     +          vx0,vy0,u0,bdlwr,bdupr,nrl,rl,sh,rmu,fa,fh,fg,fsm,fsu,
     1          fb,fd,fp,fdl,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy)
            if(itask==8) call eleas4(i,itnode,ibndry,itdof,mark,vx,vy,
     +          sf,u,um,nrl,rl,fsu,fsm,fg,fdl,ispd,icurv,
     1          a1xy,a2xy,fxy,p1xy,sxy)
            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)
        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
                    call elebdi(i,j,itnode,ibndry,ibedge,
     +                  itdof,vx,vy,sf,u,uc,nrl,rl,fa,fh,fg,fsm,
     1                  fsu,fb,fd,fp,fdl,iprob,p2xy,sxy)
                    if(itask==8) then
                        call elebd4(i,j,itnode,ibndry,ibedge,
     +                      itdof,mark,vx,vy,sf,u,nrl,rl,fg,
     1                      fsu,fdl,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)
                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,nrl,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)
            endif
        enddo
c
c       dirichlet boundary conditions depending on rl
c
        amtx=jns(ja(nb+1))-jns(ja(1))
        if(iprob>=3.and.iprob<=4) then
            lensu=ndf+ndd
            call fixdbc(nb,nbf,lensu,ndf,ibndry,ibedge,itdof,
     +          itnode,vx,vy,sf,nrl,rl,iprob,ispd,lenja,ja,js,jns,
     1          map,ibs,ibp,amtx,a,h,g,su,sm,u,um,d,dl,gdxy,sxy)
        endif
c
c       modifications for bordered systems
c
c       residual form of d-vector
c
        if(iprob==3.or.iprob==4) then
            do j=1,nrl
                ird=(j-1)*ndf
                isd=(j-1)*(ndf+ndd)
                iud=(j-1)*maxd
                call blkmlt(ndd,newndf,ndf,nb,ja,ibs,ibp,
     +              a,ir0,ja0,a0,udot(iud+1),rd(ird+1),ispd)
                if(iprob==3) then
                    do i=1,newndf
                        rd(i)=d(i)-rd(i)
                    enddo
                    do i=newndf+1,ndf
                        rd(i)=0.0e0_rknd
                    enddo
                else
                    do i=1,newndf
                        rd(i+ird)=sm(i+isd)-rd(i+ird)
                    enddo
                    do i=newndf+1,ndf
                        rd(i+ird)=0.0e0_rknd
                    enddo
                endif
            enddo
        endif
c
c       set dirichlet boundary conditions
c
        call cdbc(ndf,nbf,itdof,ibndry,ibedge,mark)
        call cdbcb(nb,nbf,itdof,ibndry,ibedge,markb,map)
        do i=1,ndf
            if(mark(i)==1) b(i)=0.0e0_rknd
        enddo
c
c       scalar function
c
        if(iprob==4) then
            do i=1,nrl
                t(i)=dl(i)
            enddo
            nn=(nrl*(nrl+1))/2
            do i=1,nn
                t(nrl+i)=g(i)
            enddo
            len=nrl+nn+1
            t(len)=r
            call pl2ip(t,len)
            do i=1,nrl
                dl(i)=t(i)
            enddo
            do i=1,nn
                g(i)=t(nrl+i)
            enddo
            r=t(len)
        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) then
            do i=1,ndf
                if(mark(i)/=1) cycle
                nn=ndf+ndd
                do j=1,nrl
                    su(i+(j-1)*nn)=0.0e0
                    sm(i+(j-1)*nn)=0.0e0
                    rd(i+(j-1)*ndf)=0.0e0
                enddo
                p(i)=0.0e0_rknd
                if(i>ndd) cycle
                do j=1,nrl
                    su(i+ndf+(j-1)*nn)=0.0e0
                    sm(i+ndf+(j-1)*nn)=0.0e0
                enddo
            enddo
            call setbdl(nrl,rl,rp,g,dl,bdlwr,bdupr)
        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(1)-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 mtxdbc(nb,ja,ibs,a,anorm,markb,ispd,1_iknd)
        call mt0dbc(ndd,newndf,ir0,ja0,a0,amtx0,mark,1_iknd)
c
        if(iprob==4) then
            call mtxdbc(nb,ja,ibs,h,0.0e0_rknd,markb,1_iknd,1_iknd)
            call mt0dbc(ndd,newndf,ir0,ja0,h0,0_iknd,mark,1_iknd)
        else if(iprob==5) then
            call mtxdbc(nb,ja,ibs,h,0.0e0_rknd,markb,1_iknd,1_iknd)
            call mtxdbc(nb,ja,ibs,sm,0.0e0_rknd,markb,0_iknd,0_iknd)
            call mtxdbc(nb,ja,ibs,su,0.0e0_rknd,markb,0_iknd,0_iknd)
            call mt0dbc(ndd,newndf,ir0,ja0,h0,0_iknd,mark,1_iknd)
            call mt0dbc(ndd,newndf,ir0,ja0,sm0,smtx0,mark,0_iknd)
            call mt0dbc(ndd,newndf,ir0,ja0,su0,smtx0,mark,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) 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==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,nvdd0,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) 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)
        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 12.0 - - - june, 2016
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)
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,id0
            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
        nrl=ip(13)
        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
                id0(k)=i2j(ivk,jrgn,ndd,newndf,ir0)
            else
                id0(k)=-ivk
            endif
        enddo
        do k=1,ndof
            ivk=ib(k)
            ivkb=id0(k)
            if(ivk<=ndd) then
                ia0(k,k)=ivkb
            else
                ia0(k,k)=0
            endif
            do j=k+1,ndof
                ivj=ib(j)
                ivjb=id0(j)
                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
cc                  b(-kk)=b(-kk)-fp(ndof+2+k)
                    b(-kk)=b(-kk)-fp(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
                kk=ib0(k)
                if(kk>0) then
                    b(kk)=b(kk)-fb(k)
                else if (-kk<=ndf) then
                    b(-kk)=b(-kk)-fb(k)
                endif
                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
                kk=ib0(k)
                if(kk>0) then
                    p(kk)=p(kk)+fp(k)
                else if (-kk<=ndf) then
                    p(-kk)=p(-kk)+fp(k)
                endif
            enddo
        else if(iprob==4) then
            if(irgn==jrgn) then
                scleqn=scleqn-fp(ndof+1)
                nn=nrl+1
                do k=1,nrl
                    dl(k)=dl(k)-fdl(k)
                    g(k)=g(k)+fg(k,k)
                    do j=k+1,nrl
                        g(nn)=g(nn)+fg(k,j)
                        nn=nn+1
                    enddo
                enddo
            endif
            do k=1,ndof
                kk=ib0(k)
                if(kk>0) then
                    p(kk)=p(kk)-fp(k)
                else if (-kk<=ndf) then
                    p(-kk)=p(-kk)-fp(k)
                endif
                do j=1,nrl
                    idx=abs(ib0(k))+(j-1)*(ndf+ndd)
                    su(idx)=su(idx)+fsu(k,j)
                    sm(idx)=sm(idx)+fsm(k,j)
                enddo
                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
cc                  dl(-kk)=dl(-kk)-fdl(ndof+2+k)
                    p(-kk)=p(-kk)-fp(k)
                    dl(-kk)=dl(-kk)-fdl(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 12.0 - - - june, 2016
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,markb,map
            integer(kind=iknd) :: amtx
            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(*) :: vx,vy,a,h,g,su,sm,b,d,
     +          u,u0,udot,um,uc,vx0,vy0,p,dl,bdlwr,bdupr,rd
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(100,100) :: fa,fh,fg,fsm,fsu
            real(kind=rknd), dimension(10) :: rl
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)
        nrl=ip(13)
        maxd=ip(85)
        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(itask==8) call cmark4(nvf,nbf,ibndry,mark)
c
        rl(1)=rp(21)
        if(abs(iprob)==6) then
            rl(1)=rp(46)
            if(itask==10) rl(1)=rl(1)+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) then
            sh=rp(64)
            do i=1,ndf
                p(i)=0.0e0_rknd
            enddo
            do i=1,nrl
                rl(i)=rp(90+i)
                dl(i)=0.0e0_rknd
            enddo
            do i=1,ndf*nrl
                sm(i)=0.0e0_rknd
                su(i)=0.0e0_rknd
            enddo
            do i=1,nrl*nrl
                g(i)=0.0e0_rknd
            enddo
            do i=1,lenas
                h(i)=0.0e0_rknd
            enddo
        else if(iprob==5) then
            sh=rp(65)
            do i=1,ndf
                dl(i)=0.0e0_rknd
                p(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
        else if(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,uc,nrl,rl,iprob,gdxy,sxy)
        enddo
c
        r=0.0e0_rknd
        drdrl=0.0e0_rknd
        scleqn=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,
     +          vx0,vy0,u0,bdlwr,bdupr,nrl,rl,sh,rmu,fa,fh,fg,fsm,fsu,
     1          fb,fd,fp,fdl,ispd,iprob,icurv,a1xy,a2xy,fxy,p1xy,sxy)
            if(itask==8) call eleas4(i,itnode,ibndry,itdof,mark,vx,vy,
     +          sf,u,um,nrl,rl,fsu,fsm,fg,fdl,ispd,icurv,
     1          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,r,drdrl)
        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
                    call elebdi(i,j,itnode,ibndry,ibedge,
     +                  itdof,vx,vy,sf,u,uc,nrl,rl,fa,fh,fg,fsm,
     1                  fsu,fb,fd,fp,fdl,iprob,p2xy,sxy)
                    if(itask==8) then
                        call elebd4(i,j,itnode,ibndry,ibedge,
     +                      itdof,mark,vx,vy,sf,u,nrl,rl,fg,
     1                      fsu,fdl,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,r,drdrl)
                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,nrl,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,r,drdrl)
c
            endif
        enddo
c
c       dirichlet boundary conditions depending on rl
c
        amtx=jns(ja(nb+1))-jns(ja(1))
        if(iprob>=3.and.iprob<=4) then
            lensu=ndf
            call fixdbc(nb,nbf,lensu,ndf,ibndry,ibedge,itdof,
     +          itnode,vx,vy,sf,nrl,rl,iprob,ispd,lenja,ja,js,jns,
     1          map,ibs,ibp,amtx,a,h,g,su,sm,u,um,d,dl,gdxy,sxy)
        endif
c
c       modifications for bordered systems
c
c       residual form of d-vector
c
        if(iprob==3.or.iprob==4) then
            do j=1,nrl
                ird=(j-1)*ndf
                isd=(j-1)*ndf
                iud=(j-1)*maxd
                call mtxmlt(ndf,nb,ja,ibs,ibp,a,udot(iud+1),
     +              rd(ird+1),ispd)
                if(iprob==3) then
                    do i=1,ndf
                        rd(i)=d(i)-rd(i)
                    enddo
                else
                    do i=1,ndf
                        rd(i+ird)=sm(i+isd)-rd(i+ird)
                    enddo
                endif
            enddo
        endif
c
c       set dirichlet boundary conditions
c
        rp(22)=r
        call cdbc(ndf,nbf,itdof,ibndry,ibedge,mark)
        call cdbcb(nb,nbf,itdof,ibndry,ibedge,markb,map)
c
        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) then
            do i=1,ndf
                if(mark(i)/=1) cycle
                do j=1,nrl
                    su(i+(j-1)*ndf)=0.0e0
                    sm(i+(j-1)*ndf)=0.0e0
                    rd(i+(j-1)*ndf)=0.0e0
                enddo
                p(i)=0.0e0_rknd
            enddo
            call setbdl(nrl,rl,rp,g,dl,bdlwr,bdupr)
        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
            enddo
            rl0=rp(31)
            r0=rp(32)
            thetal=rp(69)
            thetar=rp(70)
            sigma=rp(71)
            scleqn=thetar*(r-r0)+thetal*(rl(1)-rl0)-sigma
            rp(67)=scleqn
            rp(73)=drdrl
        endif
c
c       matrix boundary conditions
c
        anorm=canorm(ispd,nb,ibs,js,jns,a)
        rp(55)=anorm
        call mtxdbc(nb,ja,ibs,a,anorm,markb,ispd,1_iknd)
c
        if(iprob==4) then
            call mtxdbc(nb,ja,ibs,h,0.0e0_rknd,markb,1_iknd,1_iknd)
        else if(iprob==5) then
            call mtxdbc(nb,ja,ibs,h,0.0e0_rknd,markb,1_iknd,1_iknd)
            call mtxdbc(nb,ja,ibs,sm,0.0e0_rknd,markb,0_iknd,0_iknd)
            call mtxdbc(nb,ja,ibs,su,0.0e0_rknd,markb,0_iknd,0_iknd)
        endif
c
        deallocate(js,jns)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function canorm(ispd,nb,ibs,js,jns,a)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ibs,js,jns
            real(kind=rknd), dimension(*) :: a
            real(kind=rknd) :: canorm
cy
        canorm=0.0e0_rknd
        if(ispd==1) then
            do i=1,nb
                do m=1,ibs(i)
                    canorm=max(canorm,abs(a(js(i)+m-1)))
                enddo
            enddo
        else
            do i=1,nb
                do m=1,ibs(i)
                    canorm=max(canorm,abs(a(jns(i)+m-1)))
                enddo
            enddo
        endif
        if(canorm<=0.0e0_rknd) canorm=1.0e0_rknd
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine fixdbc(nb,nbf,lensu,ndf,ibndry,ibedge,itdof,
     +      itnode,vx,vy,sf,nrl,rl,iprob,ispd,lenja,ja,js,jns,map,
     1      ibs,ibp,amtx,a,h,g,su,sm,u,um,d,dl,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(2,*) :: ibedge
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(2*lenja) :: jc
            integer(kind=iknd), dimension(*) :: ibs,ibp,ja,js,jns,map
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(ndf) :: mark,imap
            integer(kind=iknd), dimension(15,15) :: gmap
            integer(kind=iknd) :: amtx
            integer(kind=iknd), dimension(4,1000) :: list
            real(kind=rknd), dimension(*) :: a,h,g,su,sm,dl,d,
     +          u,um,vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(15,10) :: gg
            real(kind=rknd), dimension(50) :: g0
            real(kind=rknd), dimension(3,20) :: cc
            real(kind=rknd), dimension(100) :: xp,yp,xn,yn
            real(kind=rknd), dimension(15) :: rr
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(15,15) :: gmtx
cy
            external gdxy,sxy
c
c       fix things up for dirichlet boundary points that might
c       depend on rl
c
c       gg( 1,*) = g
c       gg( 2,*) = dg/drl
c
c       compute jc mark relevant vertices to avoid double counting
c
        call ja2jc(nb,ja,jc)
c
        do i=1,ndf
            mark(i)=0
            imap(i)=0
        enddo
        do iedge=1,nbf
            if(ibndry(4,iedge)/=2) cycle
            call l2gmpe(iedge,ibedge,iord,idof,itdof)
            do i=1,iord+1
                mark(idof(i))=-1
            enddo
        enddo
c
c       make gmap for iprob=4
c
        if(iprob==4) then
            k=nrl
            do i=1,nrl
                gmap(i,i)=i
                do j=i+1,nrl
                    k=k+1
                    gmap(i,j)=k
                    gmap(j,i)=k
                enddo
            enddo
        endif
c
        do i=1,nrl
            rr(i)=rl(i)
        enddo
c
c       the main loop
c
        do iedge=1,nbf
            if(ibndry(4,iedge)/=2) cycle
            call l2gmpe(iedge,ibedge,iord,idof,itdof)
c
            itag=ibndry(7,iedge)
c
            npts=iord+1
            do i=1,npts
                imap(idof(i))=i
                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,nrl,rl,npts,cc,xp,yp,xn,yn,hh,sxy)
c
c       function evaluations
c
            do i=1,npts
                do k=1,3+4*nrl
                    g0(k)=0.0e0_rknd
                enddo
                call gdxy(xp(i),yp(i),rr,itag,g0)
                do k=1,nrl+1
                    gg(k,i)=g0(k)
                enddo
            enddo
c
c       mapping for row/col iv
c
            do i=1,npts
                iv=idof(i)
                if(mark(iv)==1) cycle
                call g2g(iv,npts,idof,map,jc,ja,ibs,ibp,js,jns,
     +               amtx,len,list)
                krow=1
                kcol=1
                if(ispd/=1) then
                    krow=2
                    kcol=3
                endif
c
c       bordering vector for continuation problem
c
                if(iprob==3) then
                    do k=npts+1,len
                        aa=a(list(kcol,k))
                        kv=list(4,k)
                        d(kv)=d(kv)+aa*gg(2,i)
                    enddo
                else
                    call gdmtx(xp(i),yp(i),rr,nrl,itag,
     +                  gg(1,i),gmtx,gdxy)
c
c       matrices su and sm, rhs of lambda eqn
c
                    do m=1,nrl
                        ll=(m-1)*lensu
                        gm=gg(m+1,i)
                        do k=1,len
                            hh=h(list(1,k))
                            aa=a(list(kcol,k))
                            kv=list(4,k)
                            kk=kv+ll
                            su(kk)=su(kk)+hh*gm
                            sm(kk)=sm(kk)+aa*gm
                            aa=u(kv)*hh+um(kv)*aa
                            dl(m)=dl(m)-aa*gm
c
c       second derivatives in g (worry about factors of 2 + iv1/iv2 test)
c
                            do mm=m,nrl
                                idx=gmap(m,mm)
                                g(idx)=g(idx)+aa*gmtx(m,mm)
                                if(imap(kv)>0) then
                                    gmm=gg(mm+1,imap(kv))
                                    g(idx)=g(idx)+gmm*hh*gm
                                endif
                            enddo
                        enddo
                    enddo
                endif
                mark(iv)=1
            enddo
            do i=1,npts
                imap(idof(i))=0
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mt0dbc(ndd,newndf,ir0,ja0,a0,amtx,mark,isw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ja0,mark,ir0
            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 columns
c
        n=ja0(1)-2
        do i=1,n
            ii=i2j(i,0_iknd,ndd,newndf,ir0)
            mi=mark(ii)
            if(mi==1) a0(i)=0.0e0_rknd
            do jj=ja0(i),ja0(i+1)-1
                if(mi==1) then
                    if(isw/=-1) a0(jj)=0.0e0_rknd
                    if(isw/=0) a0(jj+amtx)=0.0e0_rknd
                else
                    if(ja0(jj)>0) then
                        mj=i2j(ja0(jj),0_iknd,ndd,newndf,ir0)
                    else
                        mj=-ja0(jj)
                    endif
                    mj=mark(mj)
                    if(mj==1) then
                        if(isw/=0) a0(jj)=0.0e0_rknd
                        if(isw/=-1) a0(jj+amtx)=0.0e0_rknd
                    endif
                endif
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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,r,drdrl)
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
        nrl=ip(13)
        ndf=ip(4)
        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) then
c
            nn=nrl+1
            do k=1,nrl
                dl(k)=dl(k)-fdl(k)
                g(k)=g(k)+fg(k,k)
                do j=k+1,nrl
                    g(nn)=g(nn)+fg(k,j)
                    nn=nn+1
                enddo
            enddo
            do k=1,ndof
                p(ib(k))=p(ib(k))-fp(k)
                do j=1,nrl
                    idx=ib(k)+(j-1)*ndf
                    su(idx)=su(idx)+fsu(k,j)
                    sm(idx)=sm(idx)+fsm(k,j)
                enddo
                do j=k,ndof
                    h(is(j,k))=h(is(j,k))+fh(j,k)
                enddo
            enddo
c
        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 12.0 - - - june, 2016
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(kd<jd) then
                    call setia(is,ins,k,j,1_iknd,1_iknd,
     +                  1_iknd,1_iknd,kjs,kj,jk)
                else
                    call setia(is,ins,j,k,1_iknd,1_iknd,
     +                  1_iknd,1_iknd,kjs,jk,kj)
                endif
            enddo
c
c       vertex-edge blocks
c
            do j=1,3
                if(iords(j)<2) cycle
                jd=map(ib(iptr(j)))
                call jamap(kd,jd,kjs,kj,jk,indx,ja,js,jns,amtx)
                if(ib(iptr(j+1)-1)>ib(iptr(j))) then
                    inc=1
                else
                    inc=-1
                endif
                if(kd<jd) then
                    call setia(is,ins,k,iptr(j),1_iknd,ibs(jd),
     +                  1_iknd,inc,kjs,kj,jk)
                else
                    call setia(is,ins,iptr(j),k,ibs(jd),1_iknd,
     +                  inc,1_iknd,kjs,jk,kj)
                endif
            enddo
c
c       vertex-element block
c
            if(iord>2) then
                jd=map(ib(iptr(4)))
                call jamap(kd,jd,kjs,kj,jk,indx,ja,js,jns,amtx)
                if(kd<jd) then
                    call setia(is,ins,k,iptr(4),1_iknd,ibs(jd),
     +                  1_iknd,1_iknd,kjs,kj,jk)
                else
                    call setia(is,ins,iptr(4),k,ibs(jd),1_iknd,
     +                  1_iknd,1_iknd,kjs,jk,kj)
                endif
            endif
c
c       edge-edge blocks
c
            if(iords(k)>1) 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(kd<jd) then
                        call setia(is,ins,iptr(k),iptr(j),ibs(kd),
     +                      ibs(jd),kinc,jinc,kjs,kj,jk)
                    else
                        call setia(is,ins,iptr(j),iptr(k),ibs(jd),
     +                      ibs(kd),jinc,kinc,kjs,jk,kj)
                    endif
                enddo
c
c       edge-element blocks
c
                if(iord>2) then
                    jd=map(ib(iptr(4)))
                    call jamap(kd,jd,kjs,kj,jk,indx,ja,js,jns,amtx)
                    if(kd<jd) then
                        call setia(is,ins,iptr(k),iptr(4),ibs(kd),
     +                      ibs(jd),kinc,1_iknd,kjs,kj,jk)
                    else
                        call setia(is,ins,iptr(4),iptr(k),ibs(jd),
     +                      ibs(kd),1_iknd,kinc,kjs,jk,kj)
                    endif
                endif
            endif
        enddo
c
c       element-element block
c
        if(iord>2) 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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine g2g(iv,ndof,idof,map,jc,ja,ibs,ibp,js,jns,
     +      amtx,len,list)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd)  :: amtx
            integer(kind=iknd), dimension(*) :: ja,jc,js,jns,
     +          ibs,ibp,map,idof
            integer(kind=iknd), dimension(4,*) :: list
cy
c       compute index set for unknown iv
c
c       list(1,*) row/col entry locations in symmetric data structure
c       list(2,*) row entry locations in non symmetric data structure
c       list(3,*) col entry locations in non symmetric data structure
c       list(4,*) row/col indices
c
        ib1=map(idof(1))
        ib2=map(idof(2))
        ib3=map(idof(ndof))
        ib=map(iv)
        ilen=ibs(ib)
        i1=ibp(ib)
        len=1
c
c       the diagonal block
c
        iis=js(ib)
        ii=jns(ib)
        list(1,len)=iis+(iv-i1)
        list(2,len)=ii+(iv-i1)
        list(3,len)=ii+(iv-i1)
        list(4,len)=iv
c
c       the upper triangle row of diagonal block
c
        isym=((iv-i1+1)*(ilen*2-(iv-i1)))/2
        num=ilen-(iv-i1)-1
        ishift=(ilen*(ilen-1))/2
        do m=1,num
            len=len+1
            list(1,len)=iis+isym
            list(2,len)=ii+isym
            list(3,len)=ii+isym+ishift
            list(4,len)=iv+m
            isym=isym+1
        enddo
c
c       the lower triangle row of diagonal block
c
        isym=ilen+(iv-i1)
        num=(iv-i1)
        ishift=(ilen*(ilen-1))/2
        do m=1,num
            len=len+1
            list(1,len)=iis+isym
            list(2,len)=ii+isym+ishift
            list(3,len)=ii+isym
            list(4,len)=i1+m-1
            isym=isym+ilen-(m+1)
        enddo
        lend=len
        len=ndof
c
c       now do off-diagonal blocks
c
        do k=jc(ib),jc(ib+1)-1
            kb=jc(k)
            klen=ibs(kb)
            k1=ibp(kb)
            if(len+klen>1000) stop 8125
            call jamap(ib,kb,iks,ik,ki,indx,ja,js,jns,amtx)
c
c       upper triangle block
c
            if(kb>ib) then
                isym=(iv-i1)*klen+iks
                irow=(iv-i1)*klen+ik
                icol=(iv-i1)*klen+ki
                if(kb==ib1.or.kb==ib2.or.kb==ib3) then
                    do m=1,klen
                        lend=lend+1
                        list(1,lend)=isym+m-1
                        list(2,lend)=irow+m-1
                        list(3,lend)=icol+m-1
                        list(4,lend)=k1+m-1
                    enddo
                else
                    do m=1,klen
                        len=len+1
                        list(1,len)=isym+m-1
                        list(2,len)=irow+m-1
                        list(3,len)=icol+m-1
                        list(4,len)=k1+m-1
                    enddo
               endif
c
c       lower triangle block
c
            else
                isym=(iv-i1)+iks
                irow=(iv-i1)+ik
                icol=(iv-i1)+ki
                if(kb==ib1.or.kb==ib2.or.kb==ib3) then
                    do m=1,klen
                        lend=lend+1
                        list(1,lend)=isym+(m-1)*ilen
                        list(2,lend)=irow+(m-1)*ilen
                        list(3,lend)=icol+(m-1)*ilen
                        list(4,lend)=k1+m-1
                    enddo
                else
                    do m=1,klen
                        len=len+1
                        list(1,len)=isym+(m-1)*ilen
                        list(2,len)=irow+(m-1)*ilen
                        list(3,len)=icol+(m-1)*ilen
                        list(4,len)=k1+m-1
                    enddo
                endif
            endif
        enddo
        if(lend/=ndof) stop 8181
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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)<itdof(j3,itri)) then
                    itdof(3+j,itri)=idof(jstrt)
                else
                    itdof(3+j,itri)=-idof(jstrt)
                endif
            else
                if(idof(jstop)>=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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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)<iord) stop 8444
            iptr(iside+1)=iptr(iside)+iords(iside)-1
        enddo
        iptr(5)=iptr(4)+((iord-1)*(iord-2))/2
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine l2gpth(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(6,*) :: ipath
            integer(kind=iknd), dimension(*) :: idof
cy
c       compute degree of freedom for edge iseg
c
        iord=ipath(6,iseg)
        ndof=iord+1
        idof(1)=ipath(3,iseg)
        idof(ndof)=ipath(4,iseg)
        if(iord==1) return
        is=ipath(5,iseg)
        if(is>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 12.0 - - - june, 2016
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)<idof(2).and.iord>2) ipath(5,iseg)=-idof(2)
        endif
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine eleasm(itri,itnode,ibndry,itdof,vx,vy,sf,u,um,uc,
     +      vx0,vy0,u0,bdlwr,bdupr,nrl,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), 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
            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) :: bx,by,d11,d12,d22
            real(kind=rknd), dimension(15) :: r,s
            real(kind=rknd), dimension(10) :: rl,rr
            real(kind=rknd), dimension(5) :: a10,a11,a12,a20,a21,a22
            real(kind=rknd), dimension(15,15) :: a1mtx,a2mtx,p1mtx,fmtx
            common /pltmg3/c(3,746),wt(746),np2(22)
cy
            external a1xy,a2xy,fxy,p1xy,sxy
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       the block matrix/rhs
c
c      |  h    a^t  su   | | du  |     | p  |
c      |  a    0    sm   | | dum | = - | b  |
c      |  su^t sm^t  g   | | duc |     | dl |
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,nrl,rl,
     +      sf,xp,yp,isw,sxy)
c
        mm=max(ndof,nrl)
        do i=1,mm
            b(i)=0.0e0_rknd
            d(i)=0.0e0_rknd
            p(i)=0.0e0_rknd
            dl(i)=0.0e0_rknd
            do j=1,mm
                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
        do i=1,3+nrl
            do j=1,3+nrl
                p1mtx(i,j)=0.0e0_rknd
                a1mtx(i,j)=0.0e0_rknd
                a2mtx(i,j)=0.0e0_rknd
                fmtx(i,j)=0.0e0_rknd
            enddo
        enddo
        p(ndof+1)=0.0e0_rknd
        p(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
            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)
                do j=1,3
                    xn(j)=x(j)
                    yn(j)=y(j)
                enddo
            else
                call beval(c(1,i),x,y,gv,gx,gy,iord,iords)
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
                we=wt(i)*det*abs(detn)
            endif
            call beval(c(1,i),xn,yn,gv,gx,gy,iord,iords)
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.or.iprob==5) then
                umu=0.0e0_rknd
                umx=0.0e0_rknd
                umy=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))
                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(1)=ucu
            else
                do k=1,nrl
                    rr(k)=rl(k)
                enddo
            endif
            do k=1,4+nrl
                ca1(k)=0.0e0_rknd
                ca2(k)=0.0e0_rknd
                cp1(k)=0.0e0_rknd
                cf(k)=0.0e0_rknd
            enddo
            if(iprob==2) then
                call p1xy(xx,yy,uu,ux,uy,rr,itag,cp1)
                call fnmtx(xx,yy,uu,ux,uy,rr,nrl,itag,cp1,p1mtx,p1xy)
            else if(iprob>=4) then
                call p1xy(xx,yy,uu,ux,uy,rr,itag,cp1)
                call fnmtx(xx,yy,uu,ux,uy,rr,nrl,itag,cp1,p1mtx,p1xy)
                call a1xy(xx,yy,uu,ux,uy,rr,itag,ca1)
                call fnmtx(xx,yy,uu,ux,uy,rr,nrl,itag,ca1,a1mtx,a1xy)
                call a2xy(xx,yy,uu,ux,uy,rr,itag,ca2)
                call fnmtx(xx,yy,uu,ux,uy,rr,nrl,itag,ca2,a2mtx,a2xy)
                call fxy(xx,yy,uu,ux,uy,rr,itag,cf)
                call fnmtx(xx,yy,uu,ux,uy,rr,nrl,itag,cf,fmtx,fxy)
            else
                call a1xy(xx,yy,uu,ux,uy,rr,itag,ca1)
                call a2xy(xx,yy,uu,ux,uy,rr,itag,ca2)
                call fxy(xx,yy,uu,ux,uy,rr,itag,cf)
                call p1xy(xx,yy,uu,ux,uy,rr,itag,cp1)
            endif
c
c       space-time derivatives
c
            if(iprob==6) then
                xx0=c(1,i)*vx0(iv1)+c(2,i)*vx0(iv2)+c(3,i)*vx0(iv3)
                yy0=c(1,i)*vy0(iv1)+c(2,i)*vy0(iv2)+c(3,i)*vy0(iv3)
                uu0=0.0e0_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
                bx(1)=ca1(2)-cf(3)
                by(1)=ca2(2)-cf(4)
                if(abs(bx(1))+abs(by(1))>0.0e0_rknd) then
                    d11(1)=ca1(3)
                    d12(1)=(ca1(4)+ca2(3))/2.0e0_rknd
                    d22(1)=ca2(4)
                    if(iprob<4) then
                        call fnmtx(xx,yy,uu,ux,uy,rr,nrl,itag,
     +                      ca1,a1mtx,a1xy)
                        call fnmtx(xx,yy,uu,ux,uy,rr,nrl,itag,
     +                      ca2,a2mtx,a2xy)
                        call fnmtx(xx,yy,uu,ux,uy,rr,nrl,itag,
     +                      cf,fmtx,fxy)
                    endif
                    do k=1,4
                        bx(k+1)=a1mtx(1,k)-fmtx(2,k)
                        by(k+1)=a2mtx(1,k)-fmtx(3,k)
                        d11(k+1)=a1mtx(2,k)
                        d12(k+1)=(a1mtx(3,k)+a2mtx(2,k))/2.0e0_rknd
                        d22(k+1)=a2mtx(3,k)
                    enddo
                    do k=1,5
                        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
                    enddo
                    dd=sqrt(det)
                    call upwind(iord,dd,bx,by,d11,d12,d22,
     +                  tx,ty,x,y,a10,a11,a12,a20,a21,a22,bh)
c
                    ss=bh**iord
                    qq=(2.0e0_rknd*ss)/(1.0e0_rknd+ss)
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
                    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)
c
                endif
            endif
c
c       basis functions for quadratic stabilization terms
c
           if(iprob==5.or.qq>0.0e0_rknd) then
                call beval2(c(1,i),xn,yn,gxx,gxy,gyy,iord,iords)
           endif
c
c      update rho
c
            p(ndof+2)=p(ndof+2)+cp1(1)*we
c
c       adjust derivatives
c
            if(iprob==4.or.iprob==5) then
                do j=1,4+nrl
                    cp1(j)=cp1(j)+umu*cf(j)+umx*ca1(j)+umy*ca2(j)
                enddo
                do j=1,3+nrl
                    do k=1,3+nrl
                        p1mtx(j,k)=p1mtx(j,k)+umu*fmtx(j,k)
     +                      +umx*a1mtx(j,k)+umy*a2mtx(j,k)
                    enddo
                enddo
            endif
c
c       element assembly
c
            p(ndof+1)=p(ndof+1)+cp1(5)*we
            if(iprob==4) then
                do j=1,nrl
                    dl(j)=dl(j)+cp1(4+j)*we
                    do m=1,nrl
                        g(m,j)=g(m,j)+p1mtx(3+m,3+j)*we
                    enddo
                enddo
            endif
            do k=1,ndof
                qx=we*gx(k)
                qy=we*gy(k)
                qv=we*gv(k)
c
                do j=1,4+nrl
                    s(j)=ca1(j)*qx+ca2(j)*qy+cf(j)*qv
                enddo
                r(1)=cp1(2)*qv+cp1(3)*qx+cp1(4)*qy
                do j=1,3+nrl
                    r(j+1)=p1mtx(1,j)*qv+p1mtx(2,j)*qx+p1mtx(3,j)*qy
                enddo
c
                b(k)=b(k)+s(1)
                p(k)=p(k)+r(1)
                if(iprob==3) d(k)=d(k)+s(5)
                if(iprob==2) then
                    do j=1,ndof
                        h(k,j)=h(k,j)+r(2)*gv(j)+r(3)*gx(j)+r(4)*gy(j)
                    enddo
                else
                    do j=1,ndof
                        a(k,j)=a(k,j)+s(2)*gv(j)+s(3)*gx(j)+s(4)*gy(j)
                    enddo
                endif
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
     +                  +sh*(qx*ucx+qy*ucy)
                    ss=p1mtx(4,4)*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)+ss*gv(j)
     +                      +sh*(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
c**                     ss2=we*det**2*abs(p1mtx(4,4))
                        ss2=we*det*abs(p1mtx(4,4))
                        qxx=ss2*gxx(k)
                        qxy=ss2*gxy(k)
                        qyy=ss2*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==4) then
                    do j=1,nrl
                        su(k,j)=su(k,j)+r(4+j)
                        sm(k,j)=sm(k,j)+s(4+j)
                    enddo
                    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.and.rmu>0.0e0_rknd) 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)<bdupr(j)) then
                    ru=ru+rmu/(u(j)-bdupr(j))
                    uu=uu+rmu/(u(j)-bdupr(j))**2
                endif
                p(k)=p(k)-ru*det
                p(ndof+2+k)=-ru*det
                h(k,k)=h(k,k)+uu*det
            enddo
        else if(iprob==5.and.rmu>0.0e0_rknd) then
            det=det/6.0e0_rknd
            do k=1,ndof
                ru=0.0e0_rknd
                uu=0.0e0_rknd
                j=idof(k)
                if(uc(j)>bdlwr(j)) then
                    ru=ru+rmu/(uc(j)-bdlwr(j))
                    uu=uu+rmu/(uc(j)-bdlwr(j))**2
                endif
                if(uc(j)<bdupr(j)) then
                    ru=ru+rmu/(uc(j)-bdupr(j))
                    uu=uu+rmu/(uc(j)-bdupr(j))**2
                endif
                dl(k)=dl(k)-ru*det
                dl(ndof+2+k)=-ru*det
                g(k,k)=g(k,k)+uu*det
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ccurv(ntf,nbf,ibndry,ibedge,icurv)
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(7,*) :: ibndry
            integer(kind=iknd), dimension(3,*) :: icurv
cy
c       mark curved edges (pointer is icen)
c
        do i=1,ntf
            do j=1,3
                icurv(j,i)=0
            enddo
        enddo
c
        do i=1,nbf
            if(ibndry(3,i)==0) cycle
            do j=1,2
                itri=ibedge(j,i)/4
                if(itri<=0) cycle
                iside=ibedge(j,i)-4*itri
                icurv(iside,itri)=i
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cnode2(itri,itnode,ibndry,itdof,icurv,vx,vy,
     +      nrl,rl,sf,xp,yp,isw,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), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(3,*) :: icurv
            integer(kind=iknd), dimension(20,20) :: map
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(5) :: lptr
            integer(kind=iknd), dimension(3) :: iords,iords0
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,15) :: values
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(100) :: xp,yp,xt,yt
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(3,100) :: c
            common /pltmg1/ic(3,363),jc(12)
cy
            data index/1,2,3,2,3,1,3,1,2/
            external sxy
c
c       compute node locations (for iso-parametric mapping)
c
        isw=0
        call locord(itri,ndof,iord,iords,itdof)
c
        do j=1,3
            xp(j)=vx(itnode(j,itri))
            yp(j)=vy(itnode(j,itri))
            if(icurv(j,itri)>0) isw=isw+1
        enddo
        if(ndof>3) 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,2+nrl
                        values(1,m)=0.0e0_rknd
                        values(2,m)=0.0e0_rknd
                    enddo
                    call sxy(rl,tt,itag,values)
                    xp(k)=values(1,1)
                    yp(k)=values(2,1)
                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,2+nrl
                        values(1,m)=0.0e0_rknd
                        values(2,m)=0.0e0_rknd
                    enddo
                    call sxy(rl,tt,itag,values)
                    xt(k)=values(1,1)
                    yt(k)=values(2,1)
                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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cnode1(iedge,iside,itnode,ibndry,ibedge,vx,vy,sf,
     +      nrl,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(2,15) :: values
            real(kind=rknd), dimension(10) :: rl
            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,2+nrl
                    values(1,m)=0.0e0
                    values(2,m)=0.0e0
                enddo
                call sxy(rl,tt,itag,values)
                xp(i)=values(1,1)
                yp(i)=values(2,1)
                ss=sqrt(values(1,2)**2+values(2,2)**2)
                xn(i)=values(2,2)/ss
                yn(i)=-values(1,2)/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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine upwind(iord,h,bx,by,d11,d12,d22,tx,ty,x,y,
     +      a10,a11,a12,a20,a21,a22,bh)
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,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
        if(min(d11(1),d22(1))<=0.0e0_rknd) return
        det=d11(1)*d22(1)-d12(1)**2
        if(abs(det)<=0.0e0_rknd) return
c
        bbx=(d22(1)*bx(1)-d12(1)*by(1))/det
        bby=(d11(1)*by(1)-d12(1)*bx(1))/det
c
c       for anisotropic diffusion, compute crosswind direction
c       (just a hack)
c
c       orthogonal transformation matirx is
c
c             | bbx  bby |
c             | bby -bbx |  /sqrt(bbx**2+bby**2)
c
        if(d11(1)/=d22(1).or.d12(1)/=0.0e0_rknd) then
            isw=1
            bx2=bbx**2/(bbx**2+bby**2)
            by2=bby**2/(bbx**2+bby**2)
            bxy=(bbx*bby)/(bbx**2+bby**2)
            an=bx2*d11(1)+by2*d22(1)+2.0e0_rknd*bxy*d12(1)
        else
            isw=0
            an=d11(1)
        endif
c
c       compute gradients, evaluate bernoulli functions
c
        kmin=1
        do j=1,3
            j2=index(2,j)
            j3=index(3,j)
            g(j)=-an*(x(j2)*x(j3)+y(j2)*y(j3))
            if(g(j)<g(kmin)) kmin=j
c
            betax=bbx*tx(j)+bby*ty(j)
            betaxp=0.0e0_rknd
            call bexp(betax,betaxp,bep,bem,dbep,dbem)
            bp(j)=bep*g(j)
            bm(j)=bem*g(j)
        enddo
c
c       possible fix-up for obtuse angle
c
cc      if(g(kmin)<0.0e0_rknd) then
cc          k2=index(2,kmin)
cc          k3=index(3,kmin)
cc          bmax=max(bp(k2),bp(k3),bm(k2),bm(k3))
cc          do j=1,3
cc              rm(j)=bm(j)/bmax
cc              rp(j)=bp(j)/bmax
cc          enddo
cc          do j=1,3
cc              j2=index(2,j)
cc              j3=index(3,j)
cc              rr=rm(j2)*rm(j3)+rp(j2)*rp(j3)
cc              r(j)=rp(j2)*rm(j3)+rr
cc              s(j)=rm(j2)*rp(j3)+rr
cc          enddo
cc          ratio=min(1.0e0_rknd,-r(kmin)/(r(k2)+r(k3)),
cc   +          -s(kmin)/(s(k2)+s(k3)))
cc          bp(kmin)=bp(kmin)*ratio
cc          bm(kmin)=bm(kmin)*ratio
cc      endif
c
c       compute upwind diffusion matrix
c
        c2=(bm(3)-bp(3)+bp(1)-bm(1))/3.0e0_rknd
        c3=(bm(1)-bp(1)+bp(2)-bm(2))/3.0e0_rknd
c
        e22=bm(3)+bp(1)-(g(3)+g(1))-c2
        e32=-bp(1)+g(1)-c3
        e23=-bm(1)+g(1)-c2
        e33=bm(1)+bp(2)-(g(1)+g(2))-c3
c
        e2=e22*tx(3)-e23*tx(2)
        e3=e32*tx(3)-e33*tx(2)
        a11(1)=a11(1)+tx(3)*e2-tx(2)*e3
        a21(1)=a21(1)+ty(3)*e2-ty(2)*e3
c
        e2=e22*ty(3)-e23*ty(2)
        e3=e32*ty(3)-e33*ty(2)
        a12(1)=a12(1)+tx(3)*e2-tx(2)*e3
        a22(1)=a22(1)+ty(3)*e2-ty(2)*e3
c
c       compute upwind convection term
c
cc      if(g(kmin)<0.0e0_rknd) then
cc          e2=3.0e0_rknd*c2-(bx(1)*x(2)+by(1)*y(2))
cc          e3=3.0e0_rknd*c3-(bx(1)*x(3)+by(1)*y(3))
cc          a10(1)=a10(1)+tx(3)*e2-tx(2)*e3
cc          a20(1)=a20(1)+ty(3)*e2-ty(2)*e3
cc      endif
c
c       now do derivatives
c
        do k=2,5
            aa=abs(bx(k))+abs(by(k))+abs(d11(k))+abs(d12(k))+abs(d22(k))
            if(aa<=0.0e0_rknd) cycle
            if(isw==1) then
                an=bx2*d11(k)+by2*d22(k)+2.0e0_rknd*bxy*d12(k)
            else
                an=d11(k)
            endif
            detp=d11(k)*d22(1)+d11(1)*d22(k)-2.0e0_rknd*d12(1)*d12(k)
            bbxp=(d22(k)*bx(1)+d22(1)*bx(k)
     +           -d12(k)*by(1)-d12(1)*by(k)-bbx*detp)/det
            bbyp=(d11(k)*by(1)+d11(1)*by(k)
     +           -d12(k)*bx(1)-d12(1)*bx(k)-bby*detp)/det
c
c       evaluate bernoulli functions
c
            do j=1,3
                j2=index(2,j)
                j3=index(3,j)
                gp(j)=-an*(x(j2)*x(j3)+y(j2)*y(j3))
c
                betax=bbx*tx(j)+bby*ty(j)
                betaxp=bbxp*tx(j)+bbyp*ty(j)
                call bexp(betax,betaxp,bep,bem,dbep,dbem)
                bp(j)=dbep*g(j)+bep*gp(j)
                bm(j)=dbem*g(j)+bem*gp(j)
            enddo
c
cc          if(g(kmin)<0.0e0_rknd) then
cc              bp(kmin)=bp(kmin)*ratio
cc              bm(kmin)=bm(kmin)*ratio
cc          endif
c
c       compute upwind diffusion matrix
c
            c2=(bm(3)-bp(3)+bp(1)-bm(1))/3.0e0_rknd
            c3=(bm(1)-bp(1)+bp(2)-bm(2))/3.0e0_rknd
c
            e22=bm(3)+bp(1)-(gp(3)+gp(1))-c2
            e32=-bp(1)+gp(1)-c3
            e23=-bm(1)+gp(1)-c2
            e33=bm(1)+bp(2)-(gp(1)+gp(2))-c3
c
            e2=e22*tx(3)-e23*tx(2)
            e3=e32*tx(3)-e33*tx(2)
            a11(k)=a11(k)+tx(3)*e2-tx(2)*e3
            a21(k)=a21(k)+ty(3)*e2-ty(2)*e3
c
            e2=e22*ty(3)-e23*ty(2)
            e3=e32*ty(3)-e33*ty(2)
            a12(k)=a12(k)+tx(3)*e2-tx(2)*e3
            a22(k)=a22(k)+ty(3)*e2-ty(2)*e3
c
c       compute upwind convection term
c
cc          if(g(kmin)>=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
        if(iord==1) return
        bh=h*(abs(bbx)+abs(bby))
        if(bh>=1.0e0) return
        dd=bh**(iord-1)
        dd=dd/(1.0e0_rknd+dd)
        do k=1,5
            a10(k)=a10(k)*dd
            a11(k)=a11(k)*dd
            a12(k)=a12(k)*dd
            a20(k)=a20(k)*dd
            a21(k)=a21(k)*dd
            a22(k)=a22(k)*dd
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine elenbc(iedge,itnode,ibndry,ibedge,itdof,vx,vy,sf,
     +      u,um,uc,nrl,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(15) :: gg
            real(kind=rknd), dimension(3,20) :: cc
            real(kind=rknd), dimension(20) :: xp,yp,xn,yn
            real(kind=rknd), dimension(10) :: rl,rr
            real(kind=rknd), dimension(15,15) :: gmtx
            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
        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,
     +      nrl,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
        if(iprob==2) return
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
            if(iprob==5) then
                rr(1)=0.0e0_rknd
                do j=1,ndof
                    rr(1)=rr(1)+gv(j)*uc(idof(j))
                enddo
            else
                do j=1,nrl
                    rr(j)=rl(j)
                enddo
            endif
            do k=1,2+nrl
                gg(k)=0.0e0_rknd
            enddo
            call gnxy(xp(i),yp(i),uu,rr,itag,gg)
            we=wt(i-1+np1(irule))*hh
            if(iprob==4.or.iprob==5) then
                call gnmtx(xp(i),yp(i),uu,rr,nrl,itag,gg,gmtx,gnxy)
            endif
            umu=0.0e0_rknd
            do j=1,ndof
                umu=umu+gv(j)*um(idof(j))
            enddo
            p(ndof+1)=p(ndof+1)+gg(3)*umu*we
            if(iprob==4) then
                do j=1,nrl
                    dl(j)=dl(j)+gg(2+j)*umu*we
                    do m=1,nrl
                        g(m,j)=g(m,j)+gmtx(1+m,1+j)*umu*we
                    enddo
                enddo
            endif
            do k=1,ndof
                q=we*gv(k)
                qm=umu*q
                b(k)=b(k)-gg(1)*q
                if(iprob==3) d(k)=d(k)-gg(3)*q
                p(k)=p(k)-gg(2)*qm
                do j=1,ndof
                    a(k,j)=a(k,j)-gg(2)*q*gv(j)
                enddo
                if(iprob==5) then
                    dl(k)=dl(k)-gg(3)*qm
                    do j=1,ndof
                        h(k,j)=h(k,j)-gmtx(1,1)*qm*gv(j)
                        g(k,j)=g(k,j)-gmtx(2,2)*qm*gv(j)
                        su(k,j)=su(k,j)-gmtx(1,2)*qm*gv(j)
                        sm(k,j)=sm(k,j)-gg(3)*q*gv(j)
                    enddo
                else if(iprob==4) then
                    do j=1,nrl
                        su(k,j)=su(k,j)-gmtx(1,1+j)*qm
                        sm(k,j)=sm(k,j)-gg(2+j)*q
                    enddo
                    do j=1,ndof
                        h(k,j)=h(k,j)-gmtx(1,1)*qm*gv(j)
                    enddo
                endif
            enddo
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine elebdi(iedge,iside,itnode,ibndry,ibedge,itdof,
     +      vx,vy,sf,u,uc,nrl,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), 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
            real(kind=rknd), dimension(15,15) :: p2mtx
            real(kind=rknd), dimension(10) :: rl,rr
            common /pltmg2/c(2,78),wt(78),np1(13)
cy
            external p2xy,sxy
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
        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,
     +      nrl,rl,npts,cc,xp,yp,xn,yn,hh,sxy)
c
        nn=max(nrl,ndof)
        do i=1,nn
            b(i)=0.0e0_rknd
            d(i)=0.0e0_rknd
            p(i)=0.0e0_rknd
            dl(i)=0.0e0_rknd
            do j=1,nn
                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
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,4+nrl
                cp(k)=0.0e0_rknd
            enddo
            if(iprob==5) then
                rr(1)=0.0e0_rknd
                do j=1,ndof
                    rr(1)=rr(1)+gv(j)*uc(idof(j))
                enddo
            else
                do k=1,nrl
                    rr(k)=rl(k)
                enddo
            endif
            call p2xy(xp(i),yp(i),xn(i),yn(i),uu,ux,uy,rr,itag,ktag,cp)
            call pnmtx(xp(i),yp(i),xn(i),yn(i),uu,ux,uy,rr,nrl,
     +          itag,ktag,cp,p2mtx,p2xy)
c
            p(ndof+1)=p(ndof+1)+cp(5)*we
            p(ndof+2)=p(ndof+2)+cp(1)*we
            if(iprob==4) then
                do j=1,nrl
                    dl(j)=dl(j)+cp(4+j)*we
                    do m=1,nrl
                         g(m,j)=g(m,j)+p2mtx(3+m,3+j)*we
                    enddo
                enddo
            endif
c
            do k=1,ndof
                qx=we*gx(k)
                qy=we*gy(k)
                qv=we*gv(k)
                r(1)=cp(2)*qv+cp(3)*qx+cp(4)*qy
                do j=1,3+nrl
                    r(j+1)=p2mtx(1,j)*qv+p2mtx(2,j)*qx+p2mtx(3,j)*qy
                enddo
c
                p(k)=p(k)+r(1)
                if(iprob==2)then
                    do j=1,ndof
                        h(k,j)=h(k,j)+r(2)*gv(j)+r(3)*gx(j)+r(4)*gy(j)
                    enddo
                else 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)+p2mtx(4,4)*qv*gv(j)
                        su(k,j)=su(k,j)+r(5)*gv(j)
                    enddo
                else if(iprob==4) then
                    do j=1,nrl
                        su(k,j)=su(k,j)+r(4+j)
                    enddo
                    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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine eledbc(iedge,itnode,ibndry,ibedge,itdof,vx,vy,
     +      sf,u,uc,nrl,rl,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,uc
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(50) :: g
            real(kind=rknd), dimension(3,20) :: cc
            real(kind=rknd), dimension(10) :: rl,rr
            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
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,
     +      nrl,rl,npts,cc,xp,yp,xn,yn,hh,sxy)
c
        do i=1,npts
            do k=1,4+3*nrl
                g(k)=0.0e0_rknd
            enddo
            ivk=idof(i)
            if(iprob==5) then
                rr(1)=uc(ivk)
            else
                do k=1,nrl
                    rr(k)=rl(k)
                enddo
            endif
            call gdxy(xp(i),yp(i),rr,itag,g)
            u(ivk)=g(1)
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine eleas4(itri,itnode,ibndry,itdof,mark,vx,vy,sf,u,um,
     +      nrl,rl,su,sm,g,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), 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) :: gv,gx,gy,
     +          gxl,gyl,gxll,gyll,xp,yp,xn,yn
            real(kind=rknd), dimension(100,100) :: su,sm,g
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(200) :: dl
            real(kind=rknd), dimension(3) :: tx,ty,x,y
            real(kind=rknd), dimension(15,3) :: txl,tyl,xl,yl
            real(kind=rknd), dimension(15,15,3) :: txll,tyll,xll,yll
            real(kind=rknd), dimension(5) :: bx,by,d11,d12,d22
            real(kind=rknd), dimension(5) :: a10,a11,a12,a20,a21,a22
            real(kind=rknd), dimension(15) :: ca1,ca2,cf,cp1,detl,
     +          uxl,uyl,umxl,umyl,pl,wel
            real(kind=rknd), dimension(15,15) :: a1mtx,a2mtx,p1mtx,
     +          fmtx,detll,uxll,uyll,umxll,umyll,pll,well
            common /pltmg3/c(3,746),wt(746),np2(22)
cy
            external a1xy,a2xy,fxy,p1xy,sxy
c
        do j=1,3
            if(mark(itnode(j,itri))>0) go to 10
        enddo
        return
c
c
   10   call l2gmap(itri,idof,ndof,iord,iords,itdof)
        irule=2*max(iord,iords(1),iords(2),iords(3))
        itag=itnode(5,itri)
c
c       compute tangent and normal vectors
c
        call afmapd(itri,itnode,ibndry,mark,nrl,rl,vx,vy,sf,tx,ty,
     +      txl,tyl,txll,tyll,x,y,xl,yl,xll,yll,det,detl,detll,sxy)
c
        call cnode2(itri,itnode,ibndry,itdof,icurv,vx,vy,nrl,rl,
     +      sf,xp,yp,isw,sxy)
c
        if(det>0.0e0_rknd) then
            det=det/2.0e0_rknd
            do i=1,nrl
                detl(i)=detl(i)/2.0e0_rknd
                do j=1,nrl
                    detll(i,j)=detll(i,j)/2.0e0_rknd
                enddo
            enddo
        else
            det=-det/2.0e0_rknd
            do i=1,nrl
                detl(i)=-detl(i)/2.0e0_rknd
                do j=1,nrl
                    detll(i,j)=-detll(i,j)/2.0e0_rknd
                enddo
            enddo
        endif
c
        do i=np2(irule),np2(irule+1)-1
c
c       evaluate basis functions
c
            if(isw==0) then
                we=wt(i)*det
                do j=1,nrl
                    wel(j)=wt(i)*detl(j)
                    do k=1,nrl
                        well(k,j)=wt(i)*detll(k,j)
                    enddo
                enddo
                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)
                do j=1,3
                    xn(j)=x(j)
                    yn(j)=y(j)
                enddo
            else
            call beval(c(1,i),x,y,gv,gx,gy,iord,iords)
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
                do k=1,nrl
                    do j=1,3
                        qx=(p22*xl(k,j)-p21*yl(k,j))/detn
                        qy=(p11*yl(k,j)-p12*xl(k,j))/detn
                        xl(k,j)=qx
                        yl(k,j)=qy
                    enddo
                    do m=k,nrl
                        do j=1,3
                            qx=(p22*xll(m,k,j)-p21*yll(m,k,j))/detn
                            qy=(p11*yll(m,k,j)-p12*xll(m,k,j))/detn
                            xll(m,k,j)=qx
                            yll(m,k,j)=qy
                            xll(k,m,j)=qx
                            yll(k,m,j)=qy
                        enddo
                    enddo
                enddo
                we=wt(i)*det*abs(detn)
                do j=1,nrl
                    wel(j)=wt(i)*detl(j)*abs(detn)
                    do k=1,nrl
                        well(k,j)=wt(i)*detll(k,j)*abs(detn)
                    enddo
                enddo
            endif
            call beval(c(1,i),xn,yn,gv,gx,gy,iord,iords)
c
c       function evaluations
c
            uu=0.0e0_rknd
            ux=0.0e0_rknd
            uy=0.0e0_rknd
            umu=0.0e0_rknd
            umx=0.0e0_rknd
            umy=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))
                umu=umu+gv(j)*um(idof(j))
                umx=umx+gx(j)*um(idof(j))
                umy=umy+gy(j)*um(idof(j))
            enddo
            do k=1,4+nrl
                ca1(k)=0.0e0_rknd
                ca2(k)=0.0e0_rknd
                cp1(k)=0.0e0_rknd
                cf(k)=0.0e0_rknd
            enddo
            call p1xy(xx,yy,uu,ux,uy,rl,itag,cp1)
            call fnmtx(xx,yy,uu,ux,uy,rl,nrl,itag,cp1,p1mtx,p1xy)
            call a1xy(xx,yy,uu,ux,uy,rl,itag,ca1)
            call fnmtx(xx,yy,uu,ux,uy,rl,nrl,itag,ca1,a1mtx,a1xy)
            call a2xy(xx,yy,uu,ux,uy,rl,itag,ca2)
            call fnmtx(xx,yy,uu,ux,uy,rl,nrl,itag,ca2,a2mtx,a2xy)
            call fxy(xx,yy,uu,ux,uy,rl,itag,cf)
            call fnmtx(xx,yy,uu,ux,uy,rl,nrl,itag,cf,fmtx,fxy)
c
c       sharfetter gummel upwinding
c
            if(ispd==0) then
                bx(1)=ca1(2)-cf(3)
                by(1)=ca2(2)-cf(4)
                if(abs(bx(1))+abs(by(1))>0.0e0_rknd) then
                    d11(1)=ca1(3)
                    d12(1)=(ca1(4)+ca2(3))/2.0e0_rknd
                    d22(1)=ca2(4)
                    do k=1,4
                        bx(k+1)=a1mtx(1,k)-fmtx(2,k)
                        by(k+1)=a2mtx(1,k)-fmtx(3,k)
                        d11(k+1)=a1mtx(2,k)
                        d12(k+1)=(a1mtx(3,k)+a2mtx(2,k))/2.0e0_rknd
                        d22(k+1)=a2mtx(3,k)
                    enddo
                    do k=1,5
                        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
                    enddo
                    dd=sqrt(det)
                    call upwind(iord,dd,bx,by,d11,d12,d22,
     +                  tx,ty,x,y,a10,a11,a12,a20,a21,a22,bh)
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
                    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)
c
                endif
            endif
c
c       adjust derivatives
c
            do k=1,nrl
                uxl(k)=0.0e0_rknd
                uyl(k)=0.0e0_rknd
                umxl(k)=0.0e0_rknd
                umyl(k)=0.0e0_rknd
                call bevl(c(1,i),k,xl,yl,gxl,gyl,iord,iords)
                do j=1,ndof
                    uxl(k)=uxl(k)+gxl(j)*u(idof(j))
                    uyl(k)=uyl(k)+gyl(j)*u(idof(j))
                    umxl(k)=umxl(k)+gxl(j)*um(idof(j))
                    umyl(k)=umyl(k)+gyl(j)*um(idof(j))
                enddo
                do m=k,nrl
                    uxll(k,m)=0.0e0_rknd
                    uyll(k,m)=0.0e0_rknd
                    umxll(k,m)=0.0e0_rknd
                    umyll(k,m)=0.0e0_rknd
                    call bevll(c(1,i),k,m,xll,yll,gxll,gyll,iord,iords)
                    do j=1,ndof
                        uxll(k,m)=uxll(k,m)+gxll(j)*u(idof(j))
                        uyll(k,m)=uyll(k,m)+gyll(j)*u(idof(j))
                        umxll(k,m)=umxll(k,m)+gxll(j)*um(idof(j))
                        umyll(k,m)=umyll(k,m)+gyll(j)*um(idof(j))
                    enddo
                    uxll(m,k)=uxll(k,m)
                    uyll(m,k)=uyll(k,m)
                    umxll(m,k)=umxll(k,m)
                    umyll(m,k)=umyll(k,m)
                enddo
            enddo
c
            pp=cp1(1)+umu*cf(1)+umx*ca1(1)+umy*ca2(1)
            do k=1,nrl
                pl(k)=(cp1(3)+umu*cf(3)+umx*ca1(3)+umy*ca2(3))*uxl(k)
     +               +(cp1(4)+umu*cf(4)+umx*ca1(4)+umy*ca2(4))*uyl(k)
     1               +umxl(k)*ca1(1)+umyl(k)*ca2(1)
                do j=k,nrl
                    zx=(cp1(3)+umu*cf(3)
     +                  +umx*ca1(3)+umy*ca2(3))*uxll(j,k)
                    zxx=((p1mtx(2,2)+umu*fmtx(2,2)
     +                  +umx*a1mtx(2,2)+umy*a2mtx(2,2))*uxl(j)
     1                  +(p1mtx(3,2)+umu*fmtx(3,2)
     1                  +umx*a1mtx(3,2)+umy*a2mtx(3,2))*uyl(j))*uxl(k)
                    zmx=(umxl(j)*ca1(3)+umyl(j)*ca2(3))*uxl(k)
     +                 +(umxl(k)*ca1(3)+umyl(k)*ca2(3))*uxl(j)
                    zy=(cp1(4)+umu*cf(4)
     +                  +umx*ca1(4)+umy*ca2(4))*uyll(j,k)
                    zyy=((p1mtx(2,3)+umu*fmtx(2,3)
     +                  +umx*a1mtx(2,3)+umy*a2mtx(2,3))*uxl(j)
     1                  +(p1mtx(3,3)+umu*fmtx(3,3)
     2                  +umx*a1mtx(3,3)+umy*a2mtx(3,3))*uyl(j))*uyl(k)
                    zmy=(umxl(j)*ca1(4)+umyl(j)*ca2(4))*uyl(k)
     +                 +(umxl(k)*ca1(4)+umyl(k)*ca2(4))*uyl(j)
                    z0=umxll(k,j)*ca1(1)+umyll(k,j)*ca2(1)
                    pll(k,j)=zx+zxx+zmx+zy+zyy+zmy+z0
                    pll(j,k)=pll(k,j)
                enddo
            enddo
c
c       element assembly  (3,3) matrix block a 3 block rhs
c
c           q=pp*we
            do j=1,nrl
                dl(j)=dl(j)+pl(j)*we+pp*wel(j)
                do k=j,nrl
                    g(j,k)=g(j,k)+pll(j,k)*we+pl(j)*wel(k)
     +                  +pl(k)*wel(j)+pp*well(j,k)
                    g(k,j)=g(j,k)
                enddo
            enddo
c
            do j=1,nrl
                call bevl(c(1,i),j,xl,yl,gxl,gyl,iord,iords)
                do k=1,ndof
c
                    p1u=cp1(2)*gv(k)+cp1(3)*gx(k)+cp1(4)*gy(k)
                    p1lu=(p1mtx(2,1)*uxl(j)+p1mtx(3,1)*uyl(j))*gv(k)
     +                  +(p1mtx(2,2)*uxl(j)+p1mtx(3,2)*uyl(j))*gx(k)
     1                  +(p1mtx(2,3)*uxl(j)+p1mtx(3,3)*uyl(j))*gy(k)
     2                  + cp1(3)*gxl(k)+cp1(4)*gyl(k)
c
                    a1u=ca1(2)*gv(k)+ca1(3)*gx(k)+ca1(4)*gy(k)
                    a1lu=(a1mtx(2,1)*uxl(j)+a1mtx(3,1)*uyl(j))*gv(k)
     +                  +(a1mtx(2,2)*uxl(j)+a1mtx(3,2)*uyl(j))*gx(k)
     1                  +(a1mtx(2,3)*uxl(j)+a1mtx(3,3)*uyl(j))*gy(k)
     2                  + ca1(3)*gxl(k)+ca1(4)*gyl(k)
c
                    a2u=ca2(2)*gv(k)+ca2(3)*gx(k)+ca2(4)*gy(k)
                    a2lu=(a2mtx(2,1)*uxl(j)+a2mtx(3,1)*uyl(j))*gv(k)
     +                  +(a2mtx(2,2)*uxl(j)+a2mtx(3,2)*uyl(j))*gx(k)
     1                  +(a2mtx(2,3)*uxl(j)+a2mtx(3,3)*uyl(j))*gy(k)
     2                  + ca2(3)*gxl(k)+ca2(4)*gyl(k)
c
                    ffu=cf(2)*gv(k)+cf(3)*gx(k)+cf(4)*gy(k)
                    fflu=(fmtx(2,1)*uxl(j)+fmtx(3,1)*uyl(j))*gv(k)
     +                  +(fmtx(2,2)*uxl(j)+fmtx(3,2)*uyl(j))*gx(k)
     1                  +(fmtx(2,3)*uxl(j)+fmtx(3,3)*uyl(j))*gy(k)
     2                  + cf(3)*gxl(k)+cf(4)*gyl(k)
c
                    su(k,j)=su(k,j)+(p1lu+umu*fflu+umx*a1lu+umy*a2lu)*we
     +                  +(p1u+umu*ffu+umx*a1u+umy*a2u)*wel(j)
     1                  +(umxl(j)*a1u+umyl(j)*a2u)*we
c
                    pv=cf(1)*gv(k)+ca1(1)*gx(k)+ca2(1)*gy(k)
                    pvl=(cf(3)*gv(k)+ca1(3)*gx(k)+ca2(3)*gy(k))*uxl(j)
     +                 +(cf(4)*gv(k)+ca1(4)*gx(k)+ca2(4)*gy(k))*uyl(j)
     1                 +ca1(1)*gxl(k)+ca2(1)*gyl(k)
                    sm(k,j)=sm(k,j)+pv*wel(j)+pvl*we
                enddo
            enddo
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine elebd4(iedge,iside,itnode,ibndry,ibedge,itdof,mark,
     +      vx,vy,sf,u,nrl,rl,g,su,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), 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) :: gv,gx,gy,
     +          gxl,gyl,gxll,gyll,xp,yp,xn,yn
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(100,100) :: g,su
            real(kind=rknd), dimension(200) :: dl
            real(kind=rknd), dimension(3) :: tx,ty,x,y
            real(kind=rknd), dimension(3,20) :: cc
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(15) :: cp2,hhl,detl,wel,pl,
     +          uxl,uyl
            real(kind=rknd), dimension(15,15) :: p2mtx,hhll,detll,
     +          well,pll,uxll,uyll
            real(kind=rknd), dimension(15,3) :: txl,tyl,xl,yl
            real(kind=rknd), dimension(15,15,3) :: txll,tyll,xll,yll
            common /pltmg2/c(2,78),wt(78),np1(13)
cy
            external p2xy,sxy
c
c       this routine computes element wise boundary integrals
c
        ktri=ibedge(iside,iedge)/4
        do j=1,3
            if(mark(itnode(j,ktri))>0) go to 10
        enddo
        return
c
   10   kside=ibedge(iside,iedge)-4*ktri
        call l2gmap(ktri,idof,ndof,iord,iords,itdof)
        irule=iords(kside)+1
c
        itag=ibndry(7,iedge)
        ktag=itnode(5,ktri)
c
c       compute tangent and normal vectors
c
        call afmapd(ktri,itnode,ibndry,mark,nrl,rl,vx,vy,sf,tx,ty,
     +      txl,tyl,txll,tyll,x,y,xl,yl,xll,yll,det,detl,detll,sxy)
c
        hh=sqrt(tx(kside)**2+ty(kside)**2)
        do i=1,nrl
            hhl(i)=(tx(kside)*txl(i,kside)+ty(kside)*tyl(i,kside))/hh
        enddo
        do i=1,nrl
            do j=i,nrl
                hhll(i,j)=(tx(kside)*txll(i,j,kside)
     +                    +ty(kside)*tyll(i,j,kside)
     1                    +txl(j,kside)*txl(i,kside)
     2                    +tyl(j,kside)*tyl(i,kside))/hh-hhl(i)*hhl(j)
                hhll(j,i)=hhll(i,j)
            enddo
        enddo
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,
     +      nrl,rl,npts,cc,xp,yp,xn,yn,hh,sxy)
c
c
        do i=1,npts
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
c       function evaluations
c
            do k=1,4+nrl
                cp2(k)=0.0e0_rknd
            enddo
            call p2xy(xp(i),yp(i),xn(i),yn(i),uu,ux,uy,rl,itag,ktag,cp2)
            call pnmtx(xp(i),yp(i),xn(i),yn(i),uu,ux,uy,rl,nrl,
     +          itag,ktag,cp2,p2mtx,p2xy)
c
c       adjust derivatives
c
            do k=1,nrl
                uxl(k)=0.0e0_rknd
                uyl(k)=0.0e0_rknd
                call bevl(cc(1,i),k,xl,yl,gxl,gyl,iord,iords)
                do j=1,ndof
                    uxl(k)=uxl(k)+gxl(j)*u(idof(j))
                    uyl(k)=uyl(k)+gyl(j)*u(idof(j))
                enddo
                do m=k,nrl
                    uxll(k,m)=0.0e0_rknd
                    uyll(k,m)=0.0e0_rknd
                    call bevll(cc(1,i),k,m,xll,yll,gxll,gyll,iord,iords)
                    do j=1,ndof
                        uxll(k,m)=uxll(k,m)+gxll(j)*u(idof(j))
                        uyll(k,m)=uyll(k,m)+gyll(j)*u(idof(j))
                    enddo
                    uxll(m,k)=uxll(k,m)
                    uyll(m,k)=uyll(k,m)
                enddo
            enddo
c
c       element assembly
c
            pp =cp2(1)
            we=wt(i-1+np1(irule))*hh
            do j=1,nrl
                pl(j)=cp2(3)*uxl(j)+cp2(4)*uyl(j)
                wel(j)=wt(i-1+np1(irule))*hhl(j)
                do k=j,nrl
                    pll(k,j)=cp2(3)*uxll(k,j)+cp2(4)*uyll(k,j)
     +                  +(p2mtx(2,2)*uxl(j)+p2mtx(2,3)*uyl(j))*uxl(k)
     1                  +(p2mtx(3,2)*uxl(j)+p2mtx(3,3)*uyl(j))*uyl(k)
                    pll(j,k)=pll(k,j)
                    well(k,j)=wt(i-1+np1(irule))*hhll(k,j)
                    well(j,k)=well(k,j)
                enddo
            enddo
c
ccccc       q=pp*we
            do j=1,nrl
                dl(j)=dl(j)+pl(j)*we+pp*wel(j)
                do k=j,nrl
                    g(j,k)=g(j,k)+pll(j,k)*we+pl(j)*wel(k)
     +                  +pl(k)*wel(j)+pp*well(j,k)
                    g(k,j)=g(j,k)
                enddo
            enddo
c
            do j=1,nrl
                call bevl(cc(1,i),j,xl,yl,gxl,gyl,iord,iords)
                p2u=cp2(2)*gv(j)+cp2(3)*gx(j)+cp2(4)*gy(j)
                do k=1,ndof
                    plu=(p2mtx(2,1)*uxl(j)+p2mtx(3,1)*uyl(j))*gv(k)
     +                 +(p2mtx(2,2)*uxl(j)+p2mtx(3,2)*uyl(j))*gx(k)
     1                 +(p2mtx(2,3)*uxl(j)+p2mtx(3,3)*uyl(j))*gy(k)
     2                 + cp2(3)*gxl(k)+cp2(4)*gyl(k)
c
                    su(k,j)=su(k,j)+plu*we+p2u*wel(j)
                enddo
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine fnmtx(x,y,u,ux,uy,rl,nrl,itag,values,vmtx,fn)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(15,15) :: vmtx,s,b
            real(kind=rknd), dimension(15) :: a,da
cy
            external fn
c
c       eventually should worry about upper/lower bounds
c
        eps=1.0e-4_rknd
        num=3+nrl
        num1=num+1
c
        a(1)=u
        a(2)=ux
        a(3)=uy
        do i=1,nrl
           a(i+3)=rl(i)
        enddo
        do j=1,num
            if(a(j)>0.0e0_rknd) then
                 da(j)=(a(j)+eps)*eps
            else
                 da(j)=(a(j)-eps)*eps
            endif
            do i=1,num
                b(i,j)=a(i)
            enddo
            b(j,j)=a(j)+da(j)
        enddo
c
        do j=1,num1
            do k=1,num
                s(j,k)=0.0e0_rknd
            enddo
        enddo
c
        do i=1,num
            call fn(x,y,b(1,i),b(2,i),b(3,i),b(4,i),itag,s(1,i))
        enddo
c
        do i=1,num
            vmtx(i,i)=(s(i+1,i)-values(i+1))/da(i)
            do j=i+1,num
                q1=(s(i+1,j)-values(i+1))/da(j)
                q2=(s(j+1,i)-values(j+1))/da(i)
                vmtx(i,j)=(q1+q2)/2.0e0_rknd
                vmtx(j,i)=vmtx(i,j)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pnmtx(x,y,dx,dy,u,ux,uy,rl,nrl,itag,jtag,values,
     +      vmtx,p2xy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values
            real(kind=rknd), dimension(15,15) :: vmtx,s,b
            real(kind=rknd), dimension(15) :: a,da
            real(kind=rknd), dimension(10) :: rl
cy
            external p2xy
c
c       eventually should worry about upper/lower bounds
c
        eps=1.0e-4_rknd
        num=3+nrl
        num1=num+1
c
        a(1)=u
        a(2)=ux
        a(3)=uy
        do i=1,nrl
           a(i+3)=rl(i)
        enddo
c
        do j=1,num
            if(a(j)>0.0e0_rknd) then
                 da(j)=(a(j)+eps)*eps
            else
                 da(j)=(a(j)-eps)*eps
            endif
            do i=1,num
                b(i,j)=a(i)
            enddo
            b(j,j)=a(j)+da(j)
        enddo
c
        do j=1,num1
            do k=1,num
                s(j,k)=0.0e0_rknd
            enddo
        enddo
c
        do i=1,num
            call p2xy(x,y,dx,dy,b(1,i),b(2,i),b(3,i),b(4,i),
     +          itag,jtag,s(1,i))
        enddo
c
        do i=1,num
            vmtx(i,i)=(s(i+1,i)-values(i+1))/da(i)
            do j=i+1,num
                q1=(s(i+1,j)-values(i+1))/da(j)
                q2=(s(j+1,i)-values(j+1))/da(i)
                vmtx(i,j)=(q1+q2)/2.0e0_rknd
                vmtx(j,i)=vmtx(i,j)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine gnmtx(x,y,u,rl,nrl,itag,values,vmtx,gnxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values
            real(kind=rknd), dimension(15,15) :: vmtx,s,b
            real(kind=rknd), dimension(15) :: a,da
            real(kind=rknd), dimension(10) :: rl
cy
            external gnxy
c
c       eventually should worry about upper/lower bounds
c
        eps=1.0e-4_rknd
        num=1+nrl
        num1=num+1
c
        a(1)=u
        do i=1,nrl
           a(i+1)=rl(i)
        enddo
        do j=1,num
            if(a(j)>0.0e0_rknd) then
                 da(j)=(a(j)+eps)*eps
            else
                 da(j)=(a(j)-eps)*eps
            endif
            do i=1,num
                b(i,j)=a(i)
            enddo
            b(j,j)=a(j)+da(j)
        enddo
c
        do j=1,num1
            do k=1,num
                s(j,k)=0.0e0_rknd
            enddo
        enddo
c
        do i=1,num
            call gnxy(x,y,b(1,i),b(2,i),itag,s(1,i))
        enddo
c
        do i=1,num
            vmtx(i,i)=(s(i+1,i)-values(i+1))/da(i)
            do j=i+1,num
                q1=(s(i+1,j)-values(i+1))/da(j)
                q2=(s(j+1,i)-values(j+1))/da(i)
                vmtx(i,j)=(q1+q2)/2.0e0_rknd
                vmtx(j,i)=vmtx(i,j)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine gdmtx(x,y,rl,nrl,itag,values,vmtx,gdxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values
            real(kind=rknd), dimension(15,15) :: vmtx,b
            real(kind=rknd), dimension(50,50) :: s
            real(kind=rknd), dimension(15) :: a,da
            real(kind=rknd), dimension(10) :: rl
cy
            external gdxy
c
c       eventually should worry about upper/lower bounds
c
        eps=1.0e-4_rknd
        num=nrl
        num1=3+4*nrl
c
        do i=1,nrl
           a(i)=rl(i)
        enddo
        do j=1,num
            if(a(j)>0.0e0_rknd) then
                 da(j)=(a(j)+eps)*eps
            else
                 da(j)=(a(j)-eps)*eps
            endif
            do i=1,nrl
                b(i,j)=rl(i)
            enddo
            b(j,j)=a(j)+da(j)
        enddo
c
        do j=1,num1
            do k=1,num
                s(j,k)=0.0e0_rknd
            enddo
        enddo
c
        do i=1,num
            call gdxy(x,y,b(1,i),itag,s(1,i))
        enddo
c
        do i=1,num
            vmtx(i,i)=(s(i+1,i)-values(i+1))/da(i)
            do j=i+1,num
                q1=(s(i+1,j)-values(i+1))/da(j)
                q2=(s(j+1,i)-values(j+1))/da(i)
                vmtx(i,j)=(q1+q2)/2.0e0_rknd
                vmtx(j,i)=vmtx(i,j)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine snmtx(rl,ss,nrl,itag,values,xmtx,ymtx,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(2,*) :: values
            real(kind=rknd), dimension(15,15) :: xmtx,ymtx
            real(kind=rknd), dimension(15) :: a,da
            real(kind=rknd), dimension(15,10) :: b
            real(kind=rknd), dimension(2,15,10) :: s
cy
            external sxy
c
c       eventually should worry about upper/lower bounds
c
        eps=1.0e-4_rknd
        num=nrl
c
        do i=1,nrl
            a(i)=rl(i)
        enddo
        do j=1,num
            do i=1,nrl
                b(i,j)=a(i)
            enddo
            if(a(j)>0.0e0_rknd) then
                 da(j)=(a(j)+eps)*eps
            else
                 da(j)=(a(j)-eps)*eps
            endif
            b(j,j)=a(j)+da(j)
        enddo
c
        do k=1,num
            do j=1,2+nrl
                 s(1,j,k)=0.0e0_rknd
                 s(2,j,k)=0.0e0_rknd
            enddo
        enddo
c
        do i=1,nrl
            call sxy(b(1,i),ss,itag,s(1,1,i))
        enddo
c
        do i=1,nrl
           xmtx(i,i)=(s(1,2+i,i)-values(1,2+i))/da(i)
           ymtx(i,i)=(s(2,2+i,i)-values(2,2+i))/da(i)
            do j=i+1,nrl
                q1=(s(1,i+2,j)-values(1,i+2))/da(j)
                q2=(s(1,j+2,i)-values(1,j+2))/da(i)
                xmtx(i,j)=(q1+q2)/2.0e0_rknd
                xmtx(j,i)=xmtx(i,j)
                q1=(s(2,i+2,j)-values(2,i+2))/da(j)
                q2=(s(2,j+2,i)-values(2,j+2))/da(i)
                ymtx(i,j)=(q1+q2)/2.0e0_rknd
                ymtx(j,i)=ymtx(i,j)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cmark4(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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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(10) :: rl
            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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine elel2p(itri,jord,itnode,itdof,vx,vy,u,b)
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,u,b
            real(kind=rknd), dimension(3) :: tx,ty,x,y
            real(kind=rknd), dimension(100) :: up,ur
            real(kind=rknd), dimension(100,12) :: g
cy
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)
        do i=1,ndof
            up(i)=u(idof(i))
        enddo
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
c***    scale1=scale1*abs(det)/6.0e0_rknd
        jdof=((jord+1)*(jord+2))/2
        do i=1,jord+1
            b(i)=rl2ip(jdof,ur,g(1,i))*scale1
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine s2x3(r,a,dc0,dc)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(3) :: dc0,dc
            real(kind=rknd), dimension(2) :: r
            real(kind=rknd), dimension(2,3) :: a
            real(kind=rknd), save, dimension(3) :: t1,t2,t3
cy
            data t1/ 1.0e0_rknd, 0.0e0_rknd,-1.0e0_rknd/
            data t2/-1.0e0_rknd, 1.0e0_rknd, 0.0e0_rknd/
            data t3/ 0.0e0_rknd,-1.0e0_rknd, 1.0e0_rknd/
c
c       set up newton equations
c
        qq=sqrt(r(1)**2+r(2)**2)
        q1=r(1)/qq
        q2=r(2)/qq
        rhs=-(q1*r(1)+q2*r(2))
        a11=q1*a(1,1)+q2*a(2,1)
        a12=q1*a(1,2)+q2*a(2,2)
        a13=q1*a(1,3)+q2*a(2,3)
        a21=q2*a(1,1)-q1*a(2,1)
        a22=q2*a(1,2)-q1*a(2,2)
        a23=q2*a(1,3)-q1*a(2,3)
        a1=max(abs(a11),abs(a12),abs(a13))
        a2=max(abs(a21),abs(a22),abs(a23))
        if(a1>0.0e0_rknd) a1=10.0e0_rknd/a1
        if(a2>0.0e0_rknd) a2=1.0e0_rknd/a2
        a11=a11*a1
        a12=a12*a1
        a13=a13*a1
        rhs=rhs*a1
        a21=a21*a2
        a22=a22*a2
        a23=a23*a2
        d11=a11**2+a12**2+a13**2
        d12=a11*a21+a12*a22+a13*a23
        d22=a21**2+a22**2+a23**2
        det=d11*d22-d12**2
c
        if(det.le.1.e-6_rknd) then
            x1=rhs/d11
            x2=0.0e0_rknd
        else
            x1=d22*rhs/det
            x2=-d12*rhs/det
        endif
c
        dc(1)=x1*a11+x2*a21
        dc(2)=x1*a12+x2*a22
        dc(3)=x1*a13+x2*a23
        s2=1.0e0_rknd/sqrt(2.0e0_rknd)
        do j=1,3
            dc0(j)=(dc(1)*t1(j)+dc(2)*t2(j)+dc(3)*t3(j))*s2
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine bevl(c,il,xl,yl,gxl,gyl,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(15,3) :: xl,yl
            real(kind=rknd), dimension(100) :: gxl,gyl
            real(kind=rknd), dimension(3,20) :: val,valx,valy
            real(kind=rknd), dimension(12,3) :: 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=xl(il,j)/d
                fy=yl(il,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)
            gxl(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
            gyl(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=(xl(il,j3)-xl(il,j2))/2.0e0_rknd
            ry=(yl(il,j3)-yl(il,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)
                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,gxl,sx)
        call trans1(iords,iord,gyl,sy)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine bevll(c,il,jl,xll,yll,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(15,15,3) :: xll,yll
            real(kind=rknd), dimension(100) :: gxll,gyll
            real(kind=rknd), dimension(3,20) :: val,valx,valy
            real(kind=rknd), dimension(12,3) :: 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=xll(il,jl,j)/d
                fy=yll(il,jl,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)
            gxll(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
            gyll(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=(xll(il,jl,j3)-xll(il,jl,j2))/2.0e0_rknd
            ry=(yll(il,jl,j3)-yll(il,jl,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)
                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,gxll,sx)
        call trans1(iords,iord,gyll,sy)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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(100,12) :: 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
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        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,1)=1.0e0_rknd
            y(j,1)=1.0e0_rknd
            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(j,k)=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(i3,ii+j)) then
                    i2=index(3,i)
                    i3=index(2,i)
                endif
                j2=ic(i2,ii+j)
                j3=ic(i3,ii+j)
c
                c0=real(ibic(iord,j2),rknd)
c
                do k=1,imid
                    slp=0.0e0_rknd
                    slm=0.0e0_rknd
                    srp=0.0e0_rknd
                    srm=0.0e0_rknd
c
c       k is the number of y (x) derivatives in sl (sr)
c
                    do m=1,min(k,j3+1)
c
c       c1 contains the coefficient with binomial coeffs
c
                        r2=real(ibic(j2,k-m),rknd)
                        r3=real(ibic(j3,m-1),rknd)
                        rr=real(ibic(iord,k-1),rknd)
                        c1=c0*r2*r3/rr
c
                        s2=x(i2,j2+1+m-k)*y(i2,1+k-m)
                        s3=x(i3,j3-m+2)*y(i3,m)
                        ss=c1*s2*s3
                        if(ss>0.0e0_rknd) then
                            slp=slp+ss
                        else
                            slm=slm+ss
                        endif
c
                        s2=y(i2,j2+1+m-k)*x(i2,1+k-m)
                        s3=y(i3,j3-m+2)*x(i3,m)
                        ss=c1*s2*s3
                        if(ss>0.0e0_rknd) then
                            srp=srp+ss
                        else
                            srm=srm+ss
                        endif
                    enddo
                    if(abs(slp+slm)>eps*(slp-slm)) then
                        g(jj+j,k)=slp+slm
                    else
                        g(jj+j,k)=0.0e0_rknd
                    endif
                    if(abs(srp+srm)>eps*(srp-srm)) then
                        g(jj+j,iord+2-k)=srp+srm
                    else
                        g(jj+j,iord+2-k)=0.0e0_rknd
                    endif
                enddo
            enddo
        enddo
        if(iord<=2) return
c
c       interior
c
        jn=jc(iord+1)-jc(iord)-3*iord
        ii=3*iord+jc(iord)-1
        jj=3*iord
        do j=1,jn
c
c       sort indices - i1/j1 are biggest i3/j3 smallest
c
            i1=1
            if(ic(2,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
                slp=0.0e0_rknd
                slm=0.0e0_rknd
                srp=0.0e0_rknd
                srm=0.0e0_rknd
                do n=1,min(k,j1+1)
                    r1=real(ibic(j1,n-1),rknd)
                    do m=max(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)
                        ss=c1*s1*s2*s3
                        if(ss>0.0e0_rknd) then
                            slp=slp+ss
                        else
                            slm=slm+ss
                        endif
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)
                        ss=c1*s1*s2*s3
                        if(ss>0.0e0_rknd) then
                            srp=srp+ss
                        else
                            srm=srm+ss
                        endif
                    enddo
                enddo
                if(abs(slp+slm)>eps*(slp-slm)) then
                    g(jj+j,k)=slp+slm
                else
                    g(jj+j,k)=0.0e0_rknd
                endif
                if(abs(srp+srm)>eps*(srp-srm)) then
                    g(jj+j,iord+2-k)=srp+srm
                else
                    g(jj+j,iord+2-k)=0.0e0_rknd
                endif
            enddo
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        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)
            g1=valx(3,ic(3,i)+1)*val(2,ic(2,i)+1)
            g2=valx(2,ic(2,i)+1)*val(3,ic(3,i)+1)
            if(abs(g1+g2)>eps*abs(g1-g2)) then
                gx(i-jc(iord+1))=g1+g2
            else
                gx(i-jc(iord+1))=0.0e0_rknd
            endif
            g1=valy(3,ic(3,i)+1)*val(2,ic(2,i)+1)
            g2=valy(2,ic(2,i)+1)*val(3,ic(3,i)+1)
            if(abs(g1+g2)>eps*abs(g1-g2)) then
                gy(i-jc(iord+1))=g1+g2
            else
                gy(i-jc(iord+1))=0.0e0_rknd
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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(20,12) :: g
            real(kind=rknd), dimension(3) :: x,y,c
            real(kind=rknd) :: linval
cy
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        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
                tm=0.0e0_rknd
                tp=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
                        tt=real(ifacpro*ibic(iord-i,m)
     +                      *ibic(i,n22-m),rknd)*(x(2)**m)
     1                      *(y(2)**(n22-m))*(x(3)**(iord-i-m))*
     2                      (y(3)**(i-n22+m))*linval
                        if(tt>0.0e0_rknd) then
                            tp=tp+tt
                        else
                            tm=tm+tt
                        endif
                    enddo
                enddo
                if(abs(tm+tp)<eps*(tp-tm)) then
                    tt=0.0e0_rknd
                else
                    tt=tm+tp
                endif
                if (j==iord+1) then
                    g(2,i+1)=tt
                else if (j==0) then
                    g(1,i+1)=tt
                else
                    g(j+2,i+1)=tt
                endif
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine afmapd(itri,itnode,ibndry,mark,nrl,rl,vx,vy,sf,tx,ty,
     +      txl,tyl,txll,tyll,x,y,xl,yl,xll,yll,det,detl,detll,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(*) :: mark
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,15,3) :: values
            real(kind=rknd), dimension(3) :: tx,ty,x,y
            real(kind=rknd), dimension(15,15,3) :: xmtx,ymtx,txll,tyll,
     +          xll,yll
            real(kind=rknd), dimension(15,3) :: txl,tyl,xl,yl
            real(kind=rknd), dimension(15) :: detl,detli
            real(kind=rknd), dimension(15,15) :: detll,detlli
            real(kind=rknd), dimension(10) :: rl
cy
            data index/1,2,3,2,3,1,3,1,2/
            external sxy
c
c       tangent and normal vectors for triangle itri
c
c
c       compute tangent and normal vectors
c
        do j=1,3
            ivj=itnode(j,itri)
            do k=1,2+nrl
                values(1,k,j)=0.0e0_rknd
                values(2,k,j)=0.0e0_rknd
            enddo
            values(1,1,j)=vx(ivj)
            values(2,1,j)=vy(ivj)
            do k=1,nrl
                do m=1,nrl
                    xmtx(k,m,j)=0.0e0_rknd
                    ymtx(k,m,j)=0.0e0_rknd
                enddo
            enddo
            if(mark(ivj)>0) then
                iedge=mark(ivj)/2
                ii=mark(ivj)-2*iedge+1
                jtag=-ibndry(3,iedge)
                ss=sf(ii,iedge)
                call sxy(rl,ss,jtag,values(1,1,j))
                call snmtx(rl,ss,nrl,jtag,values(1,1,j),
     +              xmtx(1,1,j),ymtx(1,1,j),sxy)
            endif
        enddo
        do j=1,3
            i2=index(2,j)
            i3=index(3,j)
            tx(j)=vx(itnode(i3,itri))-vx(itnode(i2,itri))
            ty(j)=vy(itnode(i3,itri))-vy(itnode(i2,itri))
            do i=1,nrl
                txl(i,j)=values(1,i+2,i3)-values(1,i+2,i2)
                tyl(i,j)=values(2,i+2,i3)-values(2,i+2,i2)
                do k=i,nrl
                    txll(i,k,j)=xmtx(i,k,i3)-xmtx(i,k,i2)
                    tyll(i,k,j)=ymtx(i,k,i3)-ymtx(i,k,i2)
                    txll(k,i,j)=txll(i,k,j)
                    tyll(k,i,j)=tyll(i,k,j)
                enddo
            enddo
        enddo
c
c       compute det
c
        det=tx(2)*ty(3)-tx(3)*ty(2)
        deti=1.0e0_rknd/det
        do i=1,nrl
            detl(i)=txl(i,2)*ty(3)-txl(i,3)*ty(2)
     +             +tx(2)*tyl(i,3)-tx(3)*tyl(i,2)
            detli(i)=-detl(i)*deti**2
        enddo
        do i=1,nrl
            do j=i,nrl
                detll(i,j)=txll(i,j,2)*ty(3)-txll(i,j,3)*ty(2)
     +                   +tx(2)*tyll(i,j,3)-tx(3)*tyll(i,j,2)
     1                   +txl(i,2)*tyl(j,3)-txl(i,3)*tyl(j,2)
     2                   +txl(j,2)*tyl(i,3)-txl(j,3)*tyl(i,2)
                detlli(i,j)=-2.0e0_rknd*detl(i)*detli(j)*deti
     +              -detll(i,j)*deti**2
                detll(j,i)=detll(i,j)
                detlli(j,i)=detlli(i,j)
            enddo
        enddo
c
c       compute normals
c
        do j=1,3
            x(j)=-ty(j)*deti
            y(j)= tx(j)*deti
            do i=1,nrl
                xl(i,j)=-tyl(i,j)*deti-ty(j)*detli(i)
                yl(i,j)= txl(i,j)*deti+tx(j)*detli(i)
                do k=i,nrl
                    xll(i,k,j)=-tyll(i,k,j)*deti-tyl(i,j)*detli(k)
     +                  -tyl(k,j)*detli(i)-ty(j)*detlli(i,k)
                    yll(i,k,j)= txll(i,k,j)*deti+txl(i,j)*detli(k)
     +                  +txl(k,j)*detli(i)+tx(j)*detlli(i,k)
                    xll(k,i,j)=xll(i,k,j)
                    yll(k,i,j)=yll(i,k,j)
                enddo
            enddo
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tstxy(x,y,u,ux,uy,nrl,rl,itag,fxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(15) :: d1a,d1b
            real(kind=rknd), dimension(15) :: v0,vu,vux,vuy
            real(kind=rknd), dimension(15,10) :: vrl
            real(kind=rknd), dimension(10) :: rl,rl0
            common /val0/k0,ku,kx,ky,kl
          external fxy
cy
c
c       the routine checks numerically the derivatives of fxy,a1xy,a2xy
c       p1xy, by comparing with finite difference approximations
c
        do i=1,4+nrl
            v0(i)=0.0e0_rknd
            vu(i)=0.0e0_rknd
            vux(i)=0.0e0_rknd
            vuy(i)=0.0e0_rknd
            do j=1,nrl
                vrl(i,j)=0.0e0_rknd
            enddo
        enddo
        eps=1.e-6_rknd
        eps1=sqrt(eps)
        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)
        do j=1,nrl
            do k=1,nrl
                rl0(k)=rl(k)
            enddo
            rl0(j)=rl0(j)+eps
            call fxy(x,y,u,ux,uy,rl0,itag,vrl(1,j))
        enddo
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)
        do j=1,nrl
            d1a(3+j)=(vrl(k0,j)-v0(k0))/eps
            d1b(3+j)=v0(kl+j-1)
        enddo
c
        do j=1,3+nrl
            q1=d1a(j)
            q2=d1b(j)
            qq=abs(q1-q2)/(abs(q1)+abs(q2)+eps1)
            if(qq>eps1) write(6,*) 'd1:',j,q1,q2,qq
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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(10) :: rl
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(2,15) :: values
cy
            external sxy
c
        nrl=ip(13)
        nbf=ip(3)
        iprob=abs(ip(6))
        if(iprob==4) then
            do i=1,nrl
                rl(i)=rp(90+i)
            enddo
        else
            rl(1)=rp(21)
        endif
        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,2+nrl
                    values(1,k)=0.0e0_rknd
                    values(2,k)=0.0e0_rknd
                enddo
                call sxy(rl,theta,itag,values)
                xx=values(1,1)
                yy=values(2,1)
                dx=vx(ivj)-xx
                dy=vy(ivj)-yy
                if(max(abs(dx),abs(dy))>eps) then
                    write(6,*) 'chksf',i,j,ivj,itag,theta,
     +                   xx,yy,vx(ivj),vy(ivj)
                    stop 5151
                endif
            enddo
        enddo
        return
        end
c***************************** file: mg2.f *****************************
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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
            real(kind=rknd), dimension(10) :: rl
            character(len=80), dimension(100) :: sp,su
cy
            external qxy,sxy
c
c       user specified ip variables
c
        ip(18)=min(9,ip(18))
        ip(18)=max(1,ip(18))
        if(ip(5)<0.or.ip(5)>ip(18)) ip(5)=1
        if(ip(6)<-5.or.ip(6)>5) ip(6)=1
        if(ip(12)/=1) ip(12)=0
        if(ip(13)<1.or.ip(13)>10) ip(13)=1
        if(abs(ip(6))/=4) ip(13)=1
        if(ip(8)/=1) ip(8)=0
        if(ip(20)<-7.or.ip(20)>7) ip(20)=0
        if(ip(17)<-1.or.ip(17)>1) ip(17)=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(ip)
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       set up rl array
c
        nrl=ip(13)
        iprob=abs(ip(6))
        if(iprob==4) then
            do i=1,nrl
                rl(i)=rp(90+i)
            enddo
        else
            rl(1)=rp(21)
        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,
     +          rl,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)
            if(ip(20)<0) nef=1
            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,
     +          rl,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,
     +              rl,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,rl,sf,gf,e,ibmptr,bump,itdof,sxy)
                call timer(3_iknd)
            endif
            ip(72)=0
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,rl,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,
     +          rl,sf,gf,e,ibmptr,bump,itdof,rp,sxy)
            ip(22)=ndtrgt
            call timer(2_iknd)
            ip(72)=0
c
c       mesh smoothing
c
        else if(iadapt==3) then
            call timer(18_iknd)
            call mvemsh(ntf,nvf,nbf,ip,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,
     +              rl,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,itnode,ibndry,vx,vy,rl,sf,
     1              maxd,gf,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
            ip(72)=0
c
c       load balance
c
        else if(iadapt==6) then
            if(irgn==1) then
                call timer(18_iknd)
                call ldbal(ntf,nbf,nproc,maxd,ip,itnode,ibndry,
     +              itdof,vx,vy,sf,e,gf)
                call timer(13_iknd)
            endif
            call timer(18_iknd)
            ip(72)=0
            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,itnode,
     +                  ibndry,vx,vy,rl,sf,maxd,gf,ipath,itdof,sxy)
                    call timer(17_iknd)
                else
                    call timer(18_iknd)
                    call paste(maxt,maxv,maxb,maxpth,ip,itnode,
     +                  ibndry,ipath,vx,vy,rl,sf,maxd,gf,1_iknd,
     1                  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,a24)')
     +          'trigen error',iflag,': maximum order exceeded'
            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 tstmsh(ntf,nvf,nbf,ip,itnode,ibndry,vx,vy,sf)
c       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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine errest(ntf,nvf,nbf,ndf,ip,rp,itnode,ibndry,vx,vy,
     +      rl,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
            real(kind=rknd), dimension(10) :: rl
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)
        if(ip(20)<0) nef=1
        ngf=ip(77)
        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)
c
        call citdof(ntf,nvf,nbf,ip,itnode,ibndry,itedge,
     +      ibedge,itldof,itdof,nblock,iblock,0_iknd,jtype)
        ndl=ip(78)
        if(iadapt>=0) then
            call timer(7_iknd)
            call cbump(ndl,ntf,nbf,maxt,maxd,nef,u,
     +          vx,vy,itnode,itedge,ibedge,itldof,nblock,
     1          iblock,ibndry,itdof,ibmptr,bump,e)
            call timer(8_iknd)
            call cnorms(ip,rp,itnode,itedge,vx,vy,ibmptr,bump,
     +          maxd,nef,u,ndf,itdof,maxt,e)
        else
            call usrfn(ntf,itnode,itdof,vx,vy,ngf,rl,maxd,u,u0,qxy)
            call timer(7_iknd)
            nef0=1
            call cbump(ndl,ntf,nbf,maxt,maxd,nef0,u0,
     +          vx,vy,itnode,itedge,ibedge,itldof,nblock,
     1          iblock,ibndry,itdof,ibmptr,bump,e)
            call timer(8_iknd)
            call cnorms(ip,rp,itnode,itedge,vx,vy,ibmptr,bump,
     +          maxd,nef0,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
            r0=1.0e0_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
                    ii=min(ii,20)
                    ratio=r0*min(ss,1.0e0_rknd)/real(2**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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine refine(maxt,maxv,maxb,maxd,ip,itnode,ibndry,vx,vy,
     +      rl,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,nref
            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(10) :: rl,thresh
            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)
        if(ip(20)<0) nef=1
        ngf=ip(77)
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        iflag=0
        mxord=ip(18)
        nrl=ip(13)
        iadapt=ip(20)
        mpisw=ip(48)
        nproc=ip(49)
        irgn=ip(50)
c
c       controls on refinement
c
        relerp=rp(86)
        if(abs(iadapt)==4.and.mpisw==1) then
            kref=-1
            ksw=0
            irefn=max(1,ip(21))
            if(iadapt>0) then
                irtype=1
                ndtrgt=(ndf*(max(2,irefn)**2-1))/nproc
            else
                irtype=-1
                ndtrgt=(4*ndf)/nproc
            endif
            ndtrgt=min(ip(22),maxd,ndf+ndtrgt)
            if(ndf>=ndtrgt) return
            etrgt=1.0e-1_rknd
            sfave=rp(82)*2.0e0_rknd
            do i=1,nvf
                iseed(i)=0
            enddo
            do i=1,ntf
                if(itnode(4,i)/=irgn) cycle
                do j=1,3
                    iseed(itnode(j,i))=1
                enddo
            enddo
            do i=1,ntf
                if(itnode(4,i)==irgn) then
                    e(i,1)=10.0e0_rknd
                else if(itnode(4,i)==0) then
                    e(i,1)=10.0e0_rknd
                else
                    ii=0
                    do j=1,3
                        ii=max(ii,iseed(itnode(j,i)))
                    enddo
                    if(ii/=0) then
                        e(i,1)=10.0e0_rknd
                    else
                        e(i,1)=0.0e0_rknd
                    endif
                endif
            enddo
            dmark=0.0e0_rknd
        else
            kref=1
            ksw=1
            irtype=ip(17)
            ndtrgt=min(ip(22),maxd,4*ndf)
            if(ndf>=ndtrgt) return
            etrgt=rp(87)/3.0e0_rknd
            sfave=rp(82)*2.0e0_rknd
c
c       initialize errors
c
            dmark=0.0e0_rknd
            do i=1,ntf
                call tqual(i,itnode,vx,vy,ibmptr,bump,itdof,nef,e1,e2)
                e(i,1)=e1
                dmark=dmark+e1
            enddo
            dmark=0.5e0_rknd*dmark
        endif
        thresh(1)=0.2e0_rknd
        do i=2,mxord
            thresh(i)=thresh(i-1)/3.0e0_rknd
        enddo
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
            nref(i)=0
            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
        erth=0.0e0_rknd
        do ii=1,ndtrgt
            itri0=p(1)
            if(e(itri0,1)<=etrgt.and.erth>dmark) exit
            call locord(itri0,ndof,iord,iords,itdof)
c
            if(irtype==1) then
                ihref=1
                call rotst1(itri0,itnode,itedge,ibndry,vx,vy,isize)
                if(isize==1) ihref=2
            else if(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)
c***            if(iord*2>=mxord.or.e(itri0,2)>sfave
c*** +              .or.relerp>thresh(iord)) then
                if(iord>=mxord.or.e(itri0,2)>sfave
     +              .or.relerp>thresh(iord)) 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,nrl,rl,
     1              maxv,maxt,maxb,maxd,gf,ngf,nef,nref,erth,
     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
c***            jord=iord*2
                jord=iord+1
                if(nref(itri0)==0) erth=erth+e(itri0,1)
                nref(itri0)=nref(itri0)+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,ibndry,itdof,gf,incdf,iv,iflag)
                if(kref==1) then
                    e1=e(itri0,1)
                    e2=e(itri0,2)
                    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) then
                        cycle
                    else if(iv(j)>0) then
                        jtri=iv(j)
                        if(nref(jtri)==0) erth=erth+e(jtri,1)
                        nref(jtri)=nref(jtri)+1
                        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)
                    else
                        if(kref/=1) cycle
                        jtri=-iv(j)
                        e(jtri,1)=max(e1,e(jtri,1))
                        e(jtri,2)=e2
                        jj=q(jtri)
                        call updhp(jj,ntf,p,q,e,1_iknd)
                    endif
                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,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
        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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mvemsh(ntf,nvf,nbf,ip,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
cy
            external sxy
c
c       move mesh
c
c
        angmin=1.0e-3_rknd
        arcmax=0.26e0_rknd
        nef=ip(76)
        if(ip(20)<0) nef=1
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,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mfe2a(ntf,nvf,nbf,ip,rp,itnode,ibndry,itdof,gf,
     +      vx,vy,sf,sxy,itype)
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(8,*) :: itdof
            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(2) :: ibmptr
            real(kind=rknd), dimension(*) :: vx,vy,gf
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(*) :: rp
            real(kind=rknd), dimension(2) :: e,bump
cy
            external sxy
c
c       move mesh
c
        angmin=1.0e-3_rknd
        arcmax=0.26e0_rknd
c
c       initailize iseed, vtype
c
        call csf(ip,rp(91),vx,vy,ibndry,sf,sxy)
        call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,jflag)
        if(jflag/=0) then
            ip(25)=jflag
            return
        endif
c
        if(itype==1) then
            ngf=ip(77)
            nef=ip(76)
            if(ip(20)<0) nef=1
            maxd=ip(85)
            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)
            call cedge5(nbf,itedge,ibedge,0_iknd)
        endif
c
        call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine unrefn(maxt,maxv,maxb,maxd,ip,rp,itnode,ibndry,
     +      vx,vy,rl,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(10) :: rl
            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
        nrl=ip(13)
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        ndf=ip(4)
        irtype=ip(17)
        nef=ip(76)
        if(ip(20)<0) nef=1
        ngf=ip(77)
        iedge=0
c
c       control parameters
c
        ndtrgt=max(ip(22),int(real(ndf,rknd)/4.0e0_rknd),0)
        if(ndtrgt<3) return
        if(ndf<=ndtrgt) return
        if(rp(12)<=0.0e0_rknd.or.rp(12)>1.0e0_rknd) rp(12)=1.0e0_rknd
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,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
        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
            else if(irtype==-1) then
                ihuref=0
            else
c
c       test for h-p unrefinement
c
c***            if((iord/2)*2/=iord) then
                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,nrl,rl,sxy)
                ndfi=ndfi+incdf
                call rmupd(nn,last,iv,maxt,itnode,ibndry,itedge,
     +             ibedge,vx,vy,sf,e,iseed,vtype,p,q,mark,qual,
     1             angmin,arcmax)
            else
c***            if((iord/2)*2/=iord) then
                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
c***            jord=iord/2
                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,itdof,
     +                  vx,vy,gf(1,ifn),bump(ii))
                enddo
c
                do j=1,3
                    jords(j)=0
                enddo
                call p2qdof(itri0,jord,jords,ndf,ngf,maxd,
     +              itedge,ibedge,ibndry,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,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
        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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine rmupd(nn,last,iv,maxt,itnode,ibndry,itedge,ibedge,
     +      vx,vy,sf,e,iseed,vtype,p,q,mark,qual,angmin,arcmax)
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
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,itedge,
     +          vtype,angmin,arcmax,vlist,tlist,elist,len)
            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,itedge,
     +              vtype,angmin,arcmax,vlist0,tlist0,elist0,len0)
                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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine hunfrm(mtf,mvf,mbf,mdf,ngf,maxt,maxv,irefn,ip,
     +      itnode,ibndry,vx,vy,rl,sf,maxd,gf,e,ibmptr,bump,itdof,
     1      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,iequv
            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(10) :: rl
            real(kind=rknd), dimension(2,15) :: values
            real(kind=rknd), dimension(100) :: gv
            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
        nrl=ip(13)
        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
        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)
        call cequve(nvf,nbf,ibndry,iequv,ja)
        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(iv1<iv2) then
                inc=1
                j1=ja(iv1)
                j2=ja(iv1+1)-1
                do j=j1,j2
                    if(ja(j)==iv2) then
                        n12=nv0+(irefn-1)*(j-ja(1))+1
                    endif
                enddo
                m1=iv1
                m2=iv2
                m12=n12
            else
                inc=-1
                j1=ja(iv2)
                j2=ja(iv2+1)-1
                do j=j1,j2
                    if(ja(j)==iv1) then
                        n12=nv0+(irefn-1)*(j-ja(1)+1)
                    endif
                enddo
                m1=iv2
                m2=iv1
                m12=n12-irefn+2
            endif
            if(ibndry(3,i)>0) 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,2+nrl
                        values(1,mm)=0.0e0_rknd
                        values(2,mm)=0.0e0_rknd
                    enddo
                    itag=-ibndry(3,i)
                    call sxy(rl,tt,itag,values)
                    vx(m12)=values(1,1)
                    vy(m12)=values(2,1)
                    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
                jv(iequv(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(iv1<iv2) then
                    if(jj>0) 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(iv1<iv2) then
                mm=nv0+(irefn-1)*(j-ja(1))+1
                inc=1
                if(len>0) 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(iv1<iv3) then
                mm=nv0+(irefn-1)*(j-ja(1))+1
                inc=1
                if(len>0) 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(iv2<iv3) then
                mm=nv0+(irefn-1)*(j-ja(1))+1
                inc=1
                if(len>0) 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(4,kk)) then
                        itdof(4,kk)=-itdof(4,kk)
                    else if(mapf(ii+2,jj+3)==itdof(4,kk)) then
                        if(itdof(2,kk)>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(5,kk)) then
                        itdof(5,kk)=-itdof(5,kk)
                    else if(mapf(ii+1,jj+2)==itdof(5,kk)) then
                        if(itdof(3,kk)>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(6,kk)) then
                        itdof(6,kk)=-itdof(6,kk)
                    else if(mapf(ii+3,jj+1)==itdof(6,kk)) then
                        if(itdof(1,kk)>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(4,kk)) then
                        itdof(4,kk)=-itdof(4,kk)
                    else if(mapf(ii,jj-1)==itdof(4,kk)) then
                        if(itdof(2,kk)>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(5,kk)) then
                        itdof(5,kk)=-itdof(5,kk)
                    else if(mapf(ii+1,jj)==itdof(5,kk)) then
                        if(itdof(3,kk)>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(6,kk)) then
                        itdof(6,kk)=-itdof(6,kk)
                    else if(mapf(ii-1,jj+1)==itdof(6,kk)) then
                        if(itdof(1,kk)>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 12.0 - - - june, 2016
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,iequv
            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=ip(18)
        irefn=ip(21)
        nbf=ip(3)
        ndf=ip(4)
        maxd=ip(85)
c
c       check irefn
c
        do it=1,ntf
            call locord(it,ndof,iord,iords,itdof)
            irefn=min(irefn,mxord-iord)
        enddo
        if(irefn<=0) then
            ip(25)=21
            return
        endif
c
c       comput ja
c
        maxlnk=4*nvf
        call setgr(ntf,nvf,nbf,itnode,ibndry,ja,maxlnk)
        call cequve(nvf,nbf,ibndry,iequv,ja)
        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)
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
                jv(iequv(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.(iv2<iv3))) then
                    i2=index(2,j)
                    i3=index(3,j)
                    itdof(3+j,it)=abs(jv(k))
                else
                    i2=index(3,j)
                    i3=index(2,j)
                    itdof(3+j,it)=-(abs(jv(k))+kord-1)
                endif
                if(jv(k)<0) cycle
                do ifn=1,ngf
                    g0(1,ifn)=gf(idof(i2),ifn)
                    g0(len+2,ifn)=gf(idof(i3),ifn)
                enddo
                if(len>0) 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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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,nrl,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(2,15) :: values
            real(kind=rknd), dimension(maxt,*) :: e
            real(kind=rknd), dimension(maxd,*) :: gf
            real(kind=rknd), dimension(10) :: rl
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,2+nrl
                        values(1,mm)=0.0e0_rknd
                        values(2,mm)=0.0e0_rknd
                    enddo
                    call sxy(rl,theta,itag,values)
                    xx=values(1,1)
                    yy=values(2,1)
                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,2+nrl
                            values(1,mm)=0.0e0_rknd
                            values(2,mm)=0.0e0_rknd
                        enddo
                        call sxy(rl,thetaj,jtag,values)
                        xx=values(1,1)
                        yy=values(2,1)
                    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)<abs(k3)) then
                keep=index(2,iiedge)
                kill=index(3,iiedge)
            else
                keep=index(3,iiedge)
                kill=index(2,iiedge)
            endif
            incdf=incdf-(iord-1)*(iord-2)/2-(iords(kill)-1)
            if(nn==1) then
                incdf=incdf-iords(iiedge)
            else if(icase==3) then
                incdf=incdf-iords(iiedge)
            endif
            ibdy=-itedge(kill,iitri)
            if(ibdy<0) then
                mtri=-ibdy/4
                medge=-ibdy-4*mtri
            else if(ibndry(4,ibdy)==0) then
                if(ibedge(1,ibdy)/4/=iitri) then
                    mtri=ibedge(1,ibdy)/4
                    medge=ibedge(1,ibdy)-4*mtri
                else
                    mtri=ibedge(2,ibdy)/4
                    medge=ibedge(2,ibdy)-4*mtri
                endif
            else
                mtri=0
                medge=0
            endif
            if(mtri>0) then
                call locord(mtri,mdof,mord,mords,itdof)
                mm=iords(keep)
                mords(medge)=mm
                if(mm<mord) then
                    incdf=incdf-(mord-1)*(mord-2)/2+(mm-1)*(mm-2)/2
                    mord=mm
                endif
                mm=mord+16*mords(1)+256*mords(2)+4096*mords(3)
                itdof(8,mtri)=mm
                itdof(3+medge,mtri)=itdof(3+keep,iitri)
            endif
            iitri=jtri
            iiedge=jedge
        enddo
c
c       vertex dofs
c
        if(i3==ii2) then
            keep=itdof(index(2,iedge),itri)
            kill=itdof(index(3,iedge),itri)
        else
            keep=itdof(index(3,iedge),itri)
            kill=itdof(index(2,iedge),itri)
        endif
        ii=1
        if(vtype(i2)>=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 12.0 - - - june, 2016
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)<h(isml)) isml=3
            imid=6-ibig-isml
            iedge=isml
        endif
c
   10   i2=itnode(index(2,iedge),itri)
        i3=itnode(index(3,iedge),itri)
        if(corner(vtype(i2))==1.and.corner(vtype(i3))==1) go to 20
c
        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       check degree of merged vertex
c
        keep=0
        if(corner(vtype(i2))==1) keep=2
        if(corner(vtype(i3))==1) keep=3
        ibdy=-itedge(iedge,itri)
        if(ibdy<0) then
            icase=4
            jtri=itedge(iedge,itri)/4
            jedge=itedge(iedge,itri)-4*jtri
            if(len2+len3-4>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<thresh) go to 20
        else if(keep==3) then
             if(g2<thresh) go to 20
        else
             if(max(g2,g3)<thresh) go to 20
        endif
        return
c
c       failed
c
   20   if(iedge==isml) then
            if(h(imid)*bias<h(isml)) then
                iedge=imid
                go to 10
            endif
        else if (iedge==imid) then
            if(h(ibig)*bias<h(isml)) then
                iedge=ibig
                go to 10
            endif
        endif
        iedge=0
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine rmgeom(i2,i3,j2,j3,icase,vtype,vx,vy,
     +      len2,len3,vlist2,elist2,vlist3,elist3,g2,g3)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: vtype,vlist2,vlist3,
     +          elist2,elist3
            real(kind=rknd), dimension(*) :: vx,vy
cy
c
c       check geometry
c
        g2=2.0e0_rknd
        if(vtype(i2)>=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 12.0 - - - june, 2016
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**2+y3**2
            s=((x2-x3)**2+(y2-y3)**2)/d
            if(sqrt(s)<epsilon(1.0e0_rknd)*1.0e2_rknd) then
                 itest=1
c**     write(6,*) 'rotst1: small element',it,s
                 return
            endif
            if(itedge(j,it)>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
c
c       test for geometry problems with curved edges
c
        isw=0
        do j=1,3
            if(itedge(j,it)>0) cycle
            ib=-itedge(j,it)
            if(ibndry(3,ib)/=0) isw=1
        enddo
        if(isw==0) return
        gg=geom(itnode(1,it),itnode(2,it),itnode(3,it),vx,vy)
        if(gg <= 0.1e0_rknd) itest=1
cc      if(itest==1) write(6,*) 'rotst1: geom',it,gg
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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**2+y3**2
            s=((x2-x3)**2+(y2-y3)**2)/d
            if(sqrt(s)<epsilon(1.0e0_rknd)*1.0e2_rknd) then
                 itest=1
c**     write(6,*) 'rotst2  hit',iv1, s
                 return
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cirlst(i,itnode,itedge,ibndry,ibedge,
     +      iseed,vtype,vlist,tlist,elist,blist,len)
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(*) :: vtype,iseed
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(500) :: elist,blist,vlist
            integer(kind=iknd), dimension(500) :: tlist
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       compute circular list for vertex i
c
        len=2
        k=iseed(i)/4
        j=iseed(i)-4*k
        vlist(1)=0
c
c       check for boundary vertex
c
        if(vtype(i)>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 12.0 - - - june, 2016
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(20,nef) :: coeff
            real(kind=rknd), dimension(100) :: gv,gx,gy,e0,e1
            real(kind=rknd), dimension(nef) :: cfmax
            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)
        i2=iord+2
c
        det=abs(det)/2.0e0_rknd
        do j=1,nef
            e0(j)=0.0e0_rknd
            e1(j)=0.0e0_rknd
            mm=ibmptr(it)+(j-1)*(iord+2)
            call cfeval(tx,ty,bump(mm),coeff(1,j),cfmax(j),iord)
        enddo
        do i=np2(irule),np2(irule+1)-1
            call eeval(c(1,i),x,y,gv,gx,gy,iord)
            dd=wt(i)*det
            do j=1,nef
                e0(j)=e0(j)+rl2ip(i2,gv,coeff(1,j))**2*dd
                e1(j)=e1(j)+(rl2ip(i2,gx,coeff(1,j))**2
     +                      +rl2ip(i2,gy,coeff(1,j))**2)*dd
            enddo
        enddo
        erh1=0.0e0_rknd
        erl2=0.0e0_rknd
        do k=1,nef
           ss=cfmax(k)**2
           erh1=erh1+e1(k)*ss
           erl2=erl2+e0(k)*ss
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tqualr(it,iord,itnode,vx,vy,
     +      u,ndl,r,itdof,itldof,bump,ratio)
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(8,*) :: itdof
            integer(kind=iknd), dimension(4,*) :: itldof
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(3) :: kords,iords,jdof
            real(kind=rknd), dimension(*) :: vx,vy,u,bump
            real(kind=rknd), dimension(ndl,*) :: r
            real(kind=rknd), dimension(100) :: up,ur
            real(kind=rknd), dimension(100,12) :: g
            real(kind=rknd), dimension(20,12) :: gg
            real(kind=rknd), dimension(3) :: x,y,tx,ty,cd
            real(kind=rknd), dimension(20) :: coeff,en,ed,d,rx,ry
            common /pltmg3/c(3,746),wt(746),np2(22)
cy
            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 i=1,ndof
            up(i)=u(idof(i))
        enddo
        call afmap(itri,itnode,vx,vy,tx,ty,x,y,det)
        i2=iord+2
        do j=1,3
            iords(j)=iord
        enddo
        ndof=((iord+1)*(iord+2))/2
c
c       compute initial form of bump
c
        iv1=jdof(1)
        iv2=jdof(2)
        iv3=jdof(3)
        do k=1,iord+1
            rx(k)=x(1)*r(iv1,k)+x(2)*r(iv2,k)+x(3)*r(iv3,k)
            ry(k)=y(1)*r(iv1,k)+y(2)*r(iv2,k)+y(3)*r(iv3,k)
        enddo
        bump(1)=rx(1)
        do k=2,iord+1
            bump(k)=(rx(k)+ry(k-1))/2.0e0_rknd
        enddo
        bump(iord+2)=ry(iord+1)
        call cfeval(tx,ty,bump,coeff,cfmax,iord)
c
c
        do k=1,iord+1
           ed(k)=0.0e0_rknd
           en(k)=0.0e0_rknd
        enddo
c
c       compute derivatives
c
        call p2q2d(up,ur,kord,iord,kords,iords)
        call deval(itri,itnode,vx,vy,g,scale1,iord)
        ddmax=0.0e0_rknd
        do i=1,iord+1
            d(i)=rl2ip(ndof,ur,g(1,i))*scale1
            ddmax=max(ddmax,abs(d(i)))
        enddo
        if(ddmax==0.0e0_rknd) ddmax=1.0e0_rknd
c
c       three point integration is enough since everything is linear
c
        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)
            do k=1,iord+1
c
c       interpolation derivative error of order iord
c
                ed(k)=ed(k)+rl2ip(i2,coeff,gg(1,k))**2
c
c       superconvergent derivative error of order iord
c
                qq=((r(j2,k)+r(j3,k))/2.0e0_rknd-d(k))/ddmax
                en(k)=en(k)+qq**2
            enddo
        enddo
c
c       final estimates combines all terms
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
        if(sd>0.0e0_rknd) then
            ratio=sn/sd
            do i=1,iord+2
                bump(i)=bump(i)*ratio
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tquali(it,itnode,vx,vy,ibmptr,bump,itdof,
     +      maxd,u,nef,erh1,erl2,uh1,ul2)
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,jords
            integer(kind=iknd), dimension(100) :: idof
            real(kind=rknd), dimension(*) :: vx,vy,bump
            real(kind=rknd), dimension(3) :: tx,ty,x,y
            real(kind=rknd), dimension(20,nef) :: coeff
            real(kind=rknd), dimension(100) :: rx,ry,rv,sx,sy,sv
            real(kind=rknd), dimension(100) :: gx,gy,gv
            real(kind=rknd), dimension(nef) :: cfmax,e0,e1,u0,u1
            real(kind=rknd), dimension(maxd,*) :: u
            real(kind=rknd), dimension(100,nef) :: up,zp
            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)
        i2=iord+2
c
        call l2gmap(it,idof,ndof,iord,iords,itdof)
        jord=iord-1
        do j=1,3
            jords(j)=iords(j)-1
        enddo
        mdof=ndof-(iord+1)
c
        det=abs(det)/2.0e0_rknd
        do ifn=1,nef
            e0(ifn)=0.0e0_rknd
            e1(ifn)=0.0e0_rknd
            u0(ifn)=0.0e0_rknd
            u1(ifn)=0.0e0_rknd
            mm=ibmptr(it)+(ifn-1)*(iord+2)
            call cfeval(tx,ty,bump(mm),coeff(1,ifn),cfmax(ifn),iord)
            do j=1,ndof
                up(j,ifn)=u(idof(j),ifn)
            enddo
            if(iord>1) 
     +          call p2q2d(up(1,ifn),zp(1,ifn),iord,jord,iords,jords)
        enddo
c
        do i=np2(irule),np2(irule+1)-1
            dd=wt(i)*det
            call eeval(c(1,i),x,y,gv,gx,gy,iord)
            call beval(c(1,i),x,y,rv,rx,ry,iord,iords)
            if(iord>1)
     +          call beval(c(1,i),x,y,sv,sx,sy,jord,jords)
            do ifn=1,nef
                q0=rl2ip(i2,gv,coeff(1,ifn))**2
                q1=(rl2ip(i2,gx,coeff(1,ifn))**2
     +             +rl2ip(i2,gy,coeff(1,ifn))**2)
                w0=rl2ip(ndof,up(1,ifn),rv)
                wx=rl2ip(ndof,up(1,ifn),rx)
                wy=rl2ip(ndof,up(1,ifn),ry)
                if(iord>1) then
                    zz=(w0-rl2ip(mdof,zp(1,ifn),sv))/cfmax(ifn)
                    zx=(wx-rl2ip(mdof,zp(1,ifn),sx))/cfmax(ifn)
                    zy=(wy-rl2ip(mdof,zp(1,ifn),sy))/cfmax(ifn)
                    q0=min(q0,zz**2)
                    q1=min(q1,(zx**2+zy**2))
                endif
                e0(ifn)=e0(ifn)+q0*dd
                e1(ifn)=e1(ifn)+q1*dd
                u0(ifn)=u0(ifn)+w0**2*dd
                u1(ifn)=u1(ifn)+(wx**2+wy**2)*dd
            enddo
        enddo
c
        uh1=0.0e0_rknd
        ul2=0.0e0_rknd
        erh1=0.0e0_rknd
        erl2=0.0e0_rknd
        do ifn=1,nef
            ss=cfmax(ifn)**2
            erh1=erh1+e1(ifn)*ss
            erl2=erl2+e0(ifn)*ss
            uh1=uh1+u1(ifn)
            ul2=ul2+u0(ifn)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cfeval(tx,ty,bump,coeff,cfmax,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
        eps=1.0e2_rknd*epsilon(1.0e0_rknd)
        cfmax=0.0e0_rknd
        do j=0,iord+1
            tp=0.0e0_rknd
            tm=0.0e0_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)*
     +                  (tx(2)**k1)*(ty(2)**k2)*
     1                  (tx(3)**k3)*(ty(3)**k4)*bump(k2+k4+1)
                    if(tt>0.0e0_rknd) then
                        tp=tp+tt
                    else
                        tm=tm+tt
                    endif
                enddo
            enddo
            if(abs(tp+tm)<eps*(tp-tm)) then
                temp=0.0e0_rknd
            else
                qq=real(ibic(iord+1,j),rknd)/real(ifac(iord+1),rknd)
                temp=(tp+tm)*(-1.0e0_rknd)**(iord+1-j)*qq
            endif
            cfmax=max(cfmax,temp)
            if (j==0) then
                coeff(2)=temp
            else if (j==iord+1) then
                coeff(1)=temp
            else
                coeff(iord+3-j)=temp
            endif
        enddo
        if(cfmax==0.0e0_rknd) cfmax=1.0e0_rknd
        do j=1,iord+2
            coeff(j)=coeff(j)/cfmax
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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,7
                    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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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)<itnode(4,i)) then
                        ibndry(1,k)=itnode(index(2,jj),ii)
                        ibndry(2,k)=itnode(index(3,jj),ii)
                    endif
                endif
                if(ibndry(3,k)<0.and.ibndry(1,k)/=ibsv) then
                    sfsv=sf(1,k)
                    sf(1,k)=sf(2,k)
                    sf(2,k)=sfsv
                endif
            enddo
        enddo
c
c       now fix vertex arrays
c
        do i=1,newnvf
            mark(i)=i
        enddo
        do i=newnvf+1,nvf
            mark(i)=0
        enddo
        do i=newntf+1,ntf
            do j=1,3
                mark(itnode(j,i))=itnode(j,i)
            enddo
        enddo
        nvnew=newnvf
        nvinew=newnvf
        do i=newnvf+1,nvf
            if(mark(i)==0) cycle
            nvnew=nvnew+1
            if(i<=nvi) nvinew=nvinew+1
            mark(i)=nvnew
            vx(nvnew)=vx(i)
            vy(nvnew)=vy(i)
        enddo
        nvf=nvnew
        nvi=nvinew
        do i=newntf+1,ntf
            do j=1,3
                itnode(j,i)=mark(itnode(j,i))
            enddo
        enddo
        do i=newnbf+1,nbf
            do j=1,2
                ibndry(j,i)=mark(ibndry(j,i))
            enddo
        enddo
c
c       now fix dof arrays
c
        do i=1,newndf
            mark(i)=i
        enddo
        do i=newndf+1,ndf
            mark(i)=0
        enddo
        do i=newntf+1,ntf
            call l2gmap(i,idof,ndof,iord,iords,itdof)
            do j=1,ndof
                mark(idof(j))=idof(j)
            enddo
        enddo
        ndnew=newndf
        ndinew=newndf
        do i=newndf+1,ndf
            if(mark(i)==0) cycle
            ndnew=ndnew+1
            if(i<=ndi) ndinew=ndinew+1
            mark(i)=ndnew
            do k=1,ngf
                gf(ndnew,k)=gf(i,k)
            enddo
        enddo
        ndf=ndnew
        ndi=ndinew
        do i=newntf+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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine clnup3(ntf,ndf,ngf,maxd,gf,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
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(ndf) :: mark
            real(kind=rknd), dimension(maxd,*) :: gf
cy
c       clean up data structure after order refinement/unrefinement
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mfe1(nvf,nbf,itmax,vx,vy,sf,iseed,vtype,
     +      itnode,itedge,ibndry,ibedge,nef,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(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(*) :: iseed,vtype,ibmptr
            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(8,*) :: itdof
            integer(kind=iknd), dimension(500) :: vlist,elist,tlist
            integer(kind=iknd), dimension(500) :: blist
            real(kind=rknd), dimension(*) :: vx,vy,bump
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(6) :: g,g1
cy
            external sxy
            data corner/0,0,1,0,1,1,0,1,0,1/
c
c       rezone the region
c
        tol=1.0e-2_rknd
        eps=0.5e0_rknd
c
c       smooth the data points
c
        call cedge5(nbf,itedge,ibedge,1_iknd)
        do itnum=1,itmax
            ifail=0
            ichng=0
            do i=1,nvf
                if(corner(vtype(i))==1) cycle
c
c       compute circular list of vertices, initial function eval
c
                call cirlst(i,itnode,itedge,ibndry,ibedge,
     +              iseed,vtype,vlist,tlist,elist,blist,len)
                len1=0
                icen=0
                if(vtype(i)>=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(fk<eps*f0) cycle
                if(gk<eps*g0) cycle
                r=g(2)*px+g(3)*py
                dk=r/(gk*pp)
                if(abs(dk)<eps) cycle
                s=g(4)*px**2+2.0e0_rknd*g(5)*px*py+g(6)*py**2
                if(r*s<0.0e0_rknd) then
                    smin=step
                else
                    smax=step
                endif
                ss=step-r/s
                if(ss>smin.and.ss<smax) then
                    step=ss
                else
                    step=(smin+smax)/2.0e0_rknd
                endif
                if(ic<10) go to 40
                if(gk>=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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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(q<qmin) then
                            qmin2=qmin
                            qmin=q
                            k2=k1
                            k1=k
                        else if(q<qmin2) then
                            qmin2=q
                            k2=k
                        endif
                    enddo
                    kbeg=len+3
                    kend=len1
                    iv=vlist(len+2)
                enddo
                xmin=vx(i)
                ymin=vy(i)
                if(vtype(i)==9) then
                    xmin1=vx(ii)
                    ymin1=vy(ii)
                endif
c
c       special cases of boundary or interface node
c
                if(vtype(i)/=1) then
                    px=vx(vf(1))-vx(vf(2))
                    py=vy(vf(1))-vy(vf(2))
                    kb=vlist(k1)
                    ka=vlist(k1+1)
                    if(k1<=len) then
                        x1=vx(ka)-vx(i)
                        y1=vy(ka)-vy(i)
                        x2=vx(kb)-vx(i)
                        y2=vy(kb)-vy(i)
                    else
                        xa=vx(ka)-vx(ii)
                        ya=vy(ka)-vy(ii)
                        xb=vx(kb)-vx(ii)
                        yb=vy(kb)-vy(ii)
                        x1=cc1*xa-ss1*ya
                        y1=ss1*xa+cc1*ya
                        x2=cc1*xb-ss1*yb
                        y2=ss1*xb+cc1*yb
                    endif
                    det=x2*y1-x1*y2
                    cd=x1**2+y1**2+x2**2+y2**2+(x1-x2)**2+(y1-y2)**2
                    bn=-(px*(y1-y2)-py*(x1-x2))
                    bd=-2.0e0_rknd*(px*(x1+x2)+py*(y1+y2))
                    ad=2.0e0_rknd*(px**2+py**2)
                    aa=ad*bn
                    if(aa/=0.0e0_rknd) then
                        bb=ad*det/aa
                        cc=(bd*det-bn*cd)/aa
                        disc=sqrt(bb**2-cc)
                        if(bb>0.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)<tol) then
                    if(icen==0) then
                        vx(i)=xmin
                        vy(i)=ymin
                    else
                        rn=(sf(1,icen)-xmin)**2
     +                      +(sf(2,icen)-ymin)**2
                        rn=sqrt(rr/rn)
                        vx(i)=sf(1,icen)+rn*(xmin-sf(1,icen))
                        vy(i)=sf(2,icen)+rn*(ymin-sf(2,icen))
                    endif
                    if(vtype(i)==9) then
                        if(icen==0) then
                            vx(ii)=xmin1
                            vy(ii)=ymin1
                        else
                            vx(ii)=sf(1,icen1)+rn*(xmin1-sf(1,icen1))
                            vy(ii)=sf(2,icen1)+rn*(ymin1-sf(2,icen1))
                        endif
                    endif
                else
                    vx(i)=(xmin+xmax)/2.0e0_rknd
                    vy(i)=(ymin+ymax)/2.0e0_rknd
                    if(vtype(i)==9) then
                        vx(ii)=(xmin1+xmax1)/2.0e0_rknd
                        vy(ii)=(ymin1+ymax1)/2.0e0_rknd
                    endif
                    qq=1.0e0_rknd
                    kbeg=ks
                    kend=len
                    iv=i
                    do iter=1,jtnum
                        do k=kbeg,kend
                            kb=vlist(k)
                            ka=vlist(k+1)
                            q=geom(iv,kb,ka,vx,vy)
                            if(q<qmin) then
                                xmax=vx(i)
                                ymax=vy(i)
                                if(vtype(i)==9) then
                                    xmax1=vx(ii)
                                    ymax1=vy(ii)
                                endif
                                go to 85
                            endif
                            qq=min(qq,q)
                        enddo
                        kbeg=len+3
                        kend=len1
                        iv=vlist(len+2)
                    enddo
                    xmin=vx(i)
                    ymin=vy(i)
                    if(vtype(i)==9) then
                        xmin1=vx(ii)
                        ymin1=vy(ii)
                    endif
                    qmin=qq
                    go to 85
                endif
            enddo
        enddo
        call cedge5(nbf,itedge,ibedge,0_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function stpmx(i,vx,vy,vlist,ks,len,px,py)
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
            real(kind=rknd) :: stpmx
cy
c       compute maximum step
c
        qmin=0.6e0_rknd
        stpmx=1.0e0_rknd
        qq=2.0e0_rknd*sqrt(3.0e0_rknd)/qmin
        do k=ks,len
            k2=vlist(k)
            k3=vlist(k+1)
            x1=vx(k2)-vx(k3)
            y1=vy(k2)-vy(k3)
            x2=vx(k2)-vx(i)
            x3=vx(k3)-vx(i)
            y2=vy(k2)-vy(i)
            y3=vy(k3)-vy(i)
            cn=x1**2+x2**2+x3**2+y1**2+y2**2+y3**2
            cd=x2*y3-x3*y2
            bn=-(px*(x2+x3)+py*(y2+y3))
            bd=(px*y1-py*x1)/2.0e0_rknd
            a=2.0e0_rknd*(px**2+py**2)
            c=cn-qq*cd
            b=bn-qq*bd
            discr=b**2-a*c
            if(discr<0.0e0_rknd) then
                aa=bd**2
                bb=bn*bd-a*cd/2.0e0_rknd
                cc=bn**2-a*cn
                if(bb>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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ldbal(ntf,nbf,nproc,maxd,ip,itnode,ibndry,
     +      itdof,vx,vy,sf,e,gf)
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(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,vx,vy
            real(kind=rknd), dimension(ntf) :: z,ev
            real(kind=rknd), dimension(3,ntf) :: wt
            real(kind=rknd), dimension(maxd,*) :: gf
cy
c       load balancing
c
        nvf=ip(2)
        ndf=ip(4)
        nef=ip(76)
        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
            do i=1,ntf
                itnode(4,i)=1
            enddo
            if(nproc<=1) go to 50
        endif
        call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,jflag)
        if(jflag/=0) then
            ip(25)=jflag
            return
        endif
        call cwt(ndf,ntf,nef,maxd,itnode,itdof,itedge,vx,vy,gf,wt)
        msize=max(ntf/(nproc*ibias),ifact)
c
        call cequvt(ntf,nproc,itnode,itedge,e,p,q,kequvc,kequv,wt)
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,wt,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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cwt(ndf,ntf,nef,maxd,itnode,itdof,itedge,vx,vy,gf,wt)
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(3,*) :: itedge
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(3,*) :: wt
            real(kind=rknd), dimension(3) :: wt0
            real(kind=rknd), dimension(maxd,*) :: gf
cy
        do i=1,ntf
            do j=1,3
                wt(j,i)=0.0e0_rknd
            enddo
        enddo
c
c       compute inital weights
c
        do i=1,nef
            umax=abs(gf(1,i))
            do j=1,ndf
                umax=max(umax,abs(gf(j,i)))
            enddo
            if(umax==0.0e0_rknd) cycle
            do itri=1,ntf
                call eleun(itri,itnode,itdof,vx,vy,gf(1,i),wt0)
                do j=1,3
                    wt(j,itri)=wt(j,itri)+wt0(j)/umax
                enddo
            enddo
        enddo
c
c       final form
c
        umax=0.0e0_rknd
        do itri=1,ntf
            do iedge=1,3
                if(itedge(iedge,itri)<=0) then
                    wt(iedge,itri)=0.0e0_rknd
                    cycle
                endif
                jtri=itedge(iedge,itri)/4
                if(jtri<itri) cycle
                jedge=itedge(iedge,itri)-4*jtri
                qq=wt(iedge,itri)+wt(jedge,jtri)
                wt(iedge,itri)=qq
                wt(jedge,jtri)=qq
                umax=max(umax,qq)
            enddo
        enddo
        do i=1,ntf
            do j=1,3
                wt(j,i)=wt(j,i)/umax
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine eleun(itri,itnode,itdof,vx,vy,u,wt0)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(3) :: iords
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy,u
            real(kind=rknd), dimension(100) :: gv,gx,gy
            real(kind=rknd), dimension(3) :: tx,ty,x,y,cc,wt0
            common /pltmg2/c(2,78),wt(78),np1(13)
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       compute normal derivatives on each edge
c
        call l2gmap(itri,idof,ndof,iord,iords,itdof)
        call afmap(itri,itnode,vx,vy,tx,ty,x,y,det)
        do iside=1,3
            qq=0.0e0_rknd
            irule=iords(iside)
            npts=np1(irule+1)-np1(irule)
            i2=index(2,iside)
            i3=index(3,iside)
            dx=vx(itnode(i2,itri))-vx(itnode(i3,itri))
            dy=vy(itnode(i2,itri))-vy(itnode(i3,itri))
            h=sqrt(dx**2+dy**2)
            dx=dx/h
            dy=dy/h
            do i=1,npts
                k=np1(irule)+i-1
                cc(i2)=c(1,k)
                cc(i3)=c(2,k)
                cc(iside)=0.0e0_rknd
c
c       evaluate basis functions
c
                call beval(cc,x,y,gv,gx,gy,iord,iords)
c
                ux=0.0e0_rknd
                uy=0.0e0_rknd
                do j=1,ndof
                    ux=ux+gx(j)*u(idof(j))
                    uy=uy+gy(j)*u(idof(j))
                enddo
                qq=qq+wt(k)*abs(ux*dy-uy*dx)
            enddo
            wt0(iside)=qq
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine lbev(ntf,ibeg,iend,p,q,itedge,ev,kequv,kequvc,
     +      wt,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(3,*) :: wt
            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,wt)
        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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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.i<k) then
                        newbdy=newbdy+1
                    endif
                endif
            enddo
        enddo
        if(newbdy+nbf>maxb) 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<k) then
                        nbf=nbf+1
                        ibndry(1,nbf)=itnode(index(2,j),i)
                        ibndry(2,nbf)=itnode(index(3,j),i)
                        ibndry(3,nbf)=0
                        ibndry(4,nbf)=0
                        ibndry(5,nbf)=nbf
                        ibndry(6,nbf)=0
                        ibndry(7,nbf)=0
                        sf(1,nbf)=0.0e0_rknd
                        sf(2,nbf)=0.0e0_rknd
                    endif
                endif
            enddo
        enddo
        ip(3)=nbf
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine crdist(ntf,irgn,nproc,itnode,itedge,ibndry,ibedge,
     +      idist)
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(ntf) :: order,mark
            integer(kind=iknd), dimension(*) :: idist
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(7,*) :: ibndry
cy
c       compute the graph distance between regions
c
        do i=1,nproc
            idist(i)=nproc+1
        enddo
        idist(irgn)=0
c
        do i=1,ntf
            mark(i)=0
        enddo
        next=1
        do i=1,ntf
            if(itnode(4,i)/=irgn) cycle
            mark(i)=1
            order(next)=i
            next=next+1
        enddo
c
        do ii=1,ntf
            if(ii>=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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mtxasm(ibeg,iend,itedge,ja,a,p,q,kequv,kequvc,n,map,
     +      wt)
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
            real(kind=rknd), dimension(3,*) :: wt
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(j<i) cycle
                if(j>iend) 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)<ja(jmin)) jmin=k
                enddo
                jtemp=ja(j-1)
                ja(j-1)=ja(jmin)
                ja(jmin)=jtemp
            enddo
        enddo
c
c       now compute a
c
        do i=1,ja(n+1)-1
            a(i)=0.0e0_rknd
        enddo
        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) then
cc                          qq=1.0e0_rknd
                            qq=1.0e0_rknd+wt(jj,it)
                            a(kmin)=a(kmin)+qq
                            a(kmax)=a(kmax)+qq
                            call jamap0(kmin,kmax,ij,ji,ja,0_iknd)
                            a(ij)=a(ij)-qq
                        endif
                    endif
                endif
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cequvt(ntf,nproc,itnode,itedge,e,p,q,mark,kequv,wt)
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
            real(kind=rknd), dimension(3,*) :: wt
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)
        qmax=max(wt(1,kt),wt(2,kt),wt(3,kt))/1.0e1_rknd
        do j=1,3
            if(wt(j,kt)<qmax) cycle
            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 12.0 - - - june, 2016
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(i<iend) go to 10
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tresid(n,ja,a,x,b,dx,ev,bnorm)
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(*) :: x,b,a,dx
cy
c       compute linear system for eigenvalue problem
c
        ispd=1
c
c       rayleigh quotient
c
        call mtxml0(n,ja,a,x,b,ispd)
        ev=rl2ip(n,x,b)/rl2nrm(n,x)**2
c
c       compute right hand side residual
c
        ss=0.0e0_rknd
        do i=1,n
            b(i)=ev*x(i)-b(i)
            ss=ss+b(i)
        enddo
c
c       make orthogonal to constant
c
        ss=ss/real(n,rknd)
        do i=1,n
            b(i)=b(i)-ss
            dx(i)=0.0e0_rknd
        enddo
        bnorm=rl2nrm(n,b)/ev
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tev(n,ja,a,ev,dev,ev0)
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,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
        ispd=1
        sd=0.0e0_rknd
        do i=1,n
            sd=sd+dev(i)
        enddo
        sd=sd/real(n,rknd)
        do i=1,n
           dev(i)=dev(i)-sd
        enddo
        call orthog(n,ev,dev,ev0,irank)
c
        call mtxml0(n,ja,a,ev,aev,ispd)
        call mtxml0(n,ja,a,dev,adev,ispd)
        call mtxml0(n,ja,a,ev0,aev0,ispd)
c
c       compute inner products for quadratic equation
c
        aa(1,1)=rl2ip(n,ev,aev)
        aa(1,2)=rl2ip(n,ev,adev)
        aa(1,3)=rl2ip(n,ev,aev0)
        aa(2,1)=aa(1,2)
        aa(2,2)=rl2ip(n,dev,adev)
        aa(2,3)=rl2ip(n,dev,aev0)
        aa(3,1)=aa(1,3)
        aa(3,2)=aa(2,3)
        aa(3,3)=rl2ip(n,ev0,aev0)
        call ev3x3(aa,r,q,irank)
c
c       reset ev
c
        ss=0.0e0_rknd
        s0=0.0e0_rknd
        do i=1,n
            s=q(2,1)*dev(i)+q(3,1)*ev0(i)
            ev(i)=q(1,1)*ev(i)+s
            ev0(i)=s
            ss=ss+ev(i)
            s0=s0+ev0(i)
        enddo
        ss=ss/real(n,rknd)
        s0=s0/real(n,rknd)
        do i=1,n
           ev(i)=ev(i)-ss
           ev0(i)=ev0(i)-s0
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine rtst(p,q,itnode,itedge,nr,list,e,nproc,msize)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: p,q,list
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(1000) :: list0,list1
            integer(kind=iknd), save :: mxlst=1000
            real(kind=rknd), dimension(*) :: e
cy
        kbeg=list(1)
        kend=list(nr+1)-1
        ktag0=itnode(4,p(kbeg))
        ktag1=itnode(4,p(kend))
        nch0=nchild(ktag0,nproc,msize)
        nch1=nchild(ktag1,nproc,msize)
c
c       compute error/number of triangles in each region
c
        ecur0=0.0e0_rknd
        ecur1=0.0e0_rknd
        ncur0=0
        ncur1=0
        do k=kbeg,kend
            if(itnode(4,p(k))==ktag0) then
                ecur0=ecur0+e(p(k))
                ncur0=ncur0+1
            else
                ecur1=ecur1+e(p(k))
                ncur1=ncur1+1
            endif
        enddo
c
        do irgn=1,nr
            ibeg=list(irgn)
            iend=list(irgn+1)-1
            itag0=itnode(4,p(ibeg))
            itag1=itnode(4,p(iend))
c
c       look for blocks split between the two regions
c
            if(itag0==itag1) cycle
   10       do i=ibeg,iend
                if(itnode(4,p(i))==itag0) imid=i
            enddo
c
            do i=ibeg,imid
                if(itnode(4,p(i))/=itag0) stop 9155
            enddo
            do i=imid+1,iend
                if(itnode(4,p(i))/=itag1) stop 9156
            enddo
c
c       see if the elements in the two part are contiguous
c
            call mklst(ibeg,imid,itedge,itnode,p,q,nr0,mxlst,list0)
            call mklst(imid+1,iend,itedge,itnode,p,q,nr1,mxlst,list1)
            if(nr0==1.and.nr1==1) cycle
c
c       move groups of elements to make both parts contiguous
c
c       compute smallest error on each side
c
            e0=ecur0+ecur1
            k0=0
            do krgn=1,nr0
                jbeg=list0(krgn)
                jend=list0(krgn+1)-1
                s=0.0e0_rknd
                do j=jbeg,jend
                    s=s+e(p(j))
                enddo
                if(s<e0) then
                    e0=s
                    k0=krgn
                endif
            enddo
            e1=ecur0+ecur1
            k1=0
            do krgn=1,nr1
                jbeg=list1(krgn)
                jend=list1(krgn+1)-1
                s=0.0e0_rknd
                do j=jbeg,jend
                    s=s+e(p(j))
                enddo
                if(s<e0) then
                    e1=s
                    k1=krgn
                endif
            enddo
c
c       decide if a swap is possible
c
            if(ecur0>ecur1) then
                if(nr0<=1) cycle
                n0=list0(k0+1)-list0(k0)
                if(ncur0-n0<nch0) cycle
                if(e0>ecur0-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-n1<nch1) cycle
                if(e1>ecur1-ecur0) cycle
                jj=list1(k1+1)-1
                mm=imid+1
                do k=1,n1
                   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+n1
                ncur1=ncur1-n1
                ecur0=ecur0+e1
                ecur1=ecur1-e1
                go to 10
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine spord(ibeg,iend,z,p,q,itnode,e,nproc,msize,
     +      newtag,oldtag,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
            integer(kind=iknd) :: newtag,oldtag
            integer(kind=iknd), dimension(5,*) :: itnode
            real(kind=rknd), dimension(*) :: z,e
cy
c
        snew=0.0e0_rknd
        sold=0.0e0_rknd
        nnew=0
        nold=0
c
c
        n=iend-ibeg+1
        nn=n/2
        do i=nn,1,-1
            call mkheap(i,n,z(ibeg),p(ibeg))
        enddo
        do i=iend,ibeg+1,-1
            i1=p(i)
            p(i)=p(ibeg)
            p(ibeg)=i1
            z1=z(i)
            z(i)=z(ibeg)
            z(ibeg)=z1
            call mkheap(1_iknd,i-ibeg,z(ibeg),p(ibeg))
        enddo
c
c
        do i=ibeg,iend
           q(p(i))=i
        enddo
c       group blocks
c
        call blkord(ibeg,iend,p,q,kequv,kequvc)
c
c       make sure region newtag has a minumum number of elements
c
        iptr=ibeg
        knew=nchild(newtag,nproc,msize)
        knew=min(knew,max(1,n/2))
        nbeg=knew+1
        do ii=1,knew
            i=p(iptr)
            iptr=iptr+1
            itnode(4,i)=newtag
            snew=snew+e(i)
            nnew=nnew+1
        enddo
c
c       make sure region oldtag has a minumum number of elements
c
        jptr=iend
        kold=nchild(oldtag,nproc,msize)
        kold=min(kold,max(1,n-knew))
        nend=n-kold
        do ii=1,kold
            i=p(jptr)
            jptr=jptr-1
            itnode(4,i)=oldtag
            sold=sold+e(i)
            nold=nold+1
        enddo
c
c       divide rmaining elements by required percentage
c
        tnew=real(knew,rknd)
        told=real(kold,rknd)
        do ii=nbeg,nend
            if(snew*told<tnew*sold) then
                i=p(iptr)
                iptr=iptr+1
                itnode(4,i)=newtag
                snew=snew+e(i)
                nnew=nnew+1
            else
                i=p(jptr)
                jptr=jptr-1
                itnode(4,i)=oldtag
                sold=sold+e(i)
                nold=nold+1
            endif
        enddo
        iptr=iptr-1
        jptr=jptr+1
        if(iptr+1/=jptr) stop 5190
        i=p(iptr)
        j=p(jptr)
        if(kequv(i)/=kequv(j)) return
c
c       find the endpoints of the split block
c
        kk=kequv(i)
        kbeg=q(kk)
        kend=kbeg
   30   if(kequv(p(kend+1))==kk) then
            kend=kend+1
            go to 30
        endif
c
c       min elements forces move to region newtag
c
        if(kbeg<nbeg.and.kend<=nend) then
            do i=jptr,kend
                itnode(4,p(i))=newtag
            enddo
c
c       min elements forces move to region oldtag
c
        else if(kbeg>=nbeg.and.kend>nend) then
            do i=kbeg,iptr
                itnode(4,p(i))=oldtag
            enddo
c
c       min element requirement forces block to split
c
        else if(kbeg<nbeg.and.kend>nend) 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 to keep block intact
c
            if(iptr-kbeg<kend-jptr) then
                do i=kbeg,iptr
                    itnode(4,p(i))=oldtag
                enddo
            else
                do i=jptr,kend
                    itnode(4,p(i))=newtag
                enddo
            endif
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function nchild(k,n,msize)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd) :: nchild
cy
c
        if(k<=0.or.k>=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<n2) then
                nchild=nchild+k2-k1+1
            else
                nchild=nchild+n2-k1+1
            endif
        endif
        nchild=nchild*msize
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine smth0(ntf,itedge,e,nproc,msize,itnode)
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), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(2*nproc) :: iwt,ichild
            integer(kind=iknd), dimension(3) :: tag,nnum,jnum
            integer(kind=iknd), dimension(3,3) :: ntag
            real(kind=rknd), dimension(*) :: e
            real(kind=rknd), dimension(2*nproc) :: wt,wtrgt
cy
            data index/1,2,3,2,3,1,3,1,2/
c
        itmax=50
c
c       initialize wt,iwt
c
        do i=1,2*nproc-1
            wt(i)=0.0e0_rknd
            iwt(i)=0
            ichild(i)=nchild(i,nproc,msize)
        enddo
        wtot=0.0e0_rknd
        do i=1,ntf
            j=itnode(4,i)
            wt(j)=wt(j)+e(i)
            iwt(j)=iwt(j)+1
            wtot=wtot+e(i)
        enddo
        do i=1,2*nproc-1
            wtrgt(i)=wtot*real(ichild(i),rknd)/real(nproc,rknd)
        enddo
c
c       the main loop
c
        do itnum=1,itmax
            ichng=0
            kchng=0
            jchng=0
            do i=1,ntf
                itag=itnode(4,i)
                if(iwt(itag)<=ichild(itag)) cycle
c
c       parameters for this triangle and its neighbors
c
                inum=0
                ibdy=0
                kk=0
                ii=0
                do j=1,3
                    nnum(j)=0
                    k=itedge(j,i)/4
                    if(k<=0) then
                        tag(j)=0
                        ibdy=ibdy+1
                    else
                        tag(j)=itnode(4,k)
                        if(tag(j)==itag) then
                            do mm=1,3
                                m=itedge(mm,k)/4
                                if(m<=0) then
                                    ntag(mm,j)=0
                                else
                                    ntag(mm,j)=itnode(4,m)
                                    if(ntag(mm,j)==itag)
     +                                  nnum(j)=nnum(j)+1
                                endif
                            enddo
                            inum=inum+1
                            ii=j
                        else
                            kk=j
                        endif
                    endif
                enddo
c
c       exclude obvious cases
c
                if(ibdy+inum>=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))<wt(tag(k3))) then
                        ktag=tag(k2)
                    else
                        ktag=tag(k3)
                    endif
                    go to 40
               else if(nnum(ii)==2) then
                    if(n2==1) then
                        ktag=tag(k2)
                    else if(n3==1) then
                        ktag=tag(k3)
                    endif
                    if(ktag>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 12.0 - - - june, 2016
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)<itnode(4,i)) then
                        ibndry(1,k)=itnode(index(2,jj),ii)
                        ibndry(2,k)=itnode(index(3,jj),ii)
                    endif
                endif
                if(ibndry(3,k)<0.and.ibndry(1,k)/=ibsv) then
                    sfsv=sf(1,k)
                    sf(1,k)=sf(2,k)
                    sf(2,k)=sfsv
                endif
            enddo
        enddo
c
c       mark edges
c
        do i=1,nbf
            p(i)=i
            if(ibndry(4,i)>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(k1rgn<k2rgn) then
                            q(i)=3
                        else
                            q(i)=0
                        endif
                    else
                        if(k1rgn==irgn) then
                            q(i)=1
                        else
                            q(i)=0
                        endif
                    endif
                endif
            endif
        enddo
c
c       reorder ibndry
c
        nbb=0
        do ii=1,nbf
            i=p(ii)
            if(q(i)==2) then
                nbb=nbb+1
                p(ii)=p(nbb)
                p(nbb)=i
            endif
        enddo
        newnbf=nbb
        do ii=nbb+1,nbf
            i=p(ii)
            if(q(i)==1) then
                newnbf=newnbf+1
                p(ii)=p(newnbf)
                p(newnbf)=i
            endif
        enddo
        nbi=newnbf
        do ii=newnbf+1,nbf
            i=p(ii)
            if(q(i)==3) then
                nbi=nbi+1
                p(ii)=p(nbi)
                p(nbi)=i
            endif
        enddo
c
c       reorder edges
c
        call border(ip,p,q,ibndry,sf)
c
c       sort interfrace entries according to label
c
        do i=1,nbf
            p(i)=0
        enddo
        do i=1,nbb
            jj=abs(ibndry(5,i))
            p(jj)=p(jj)+1
        enddo
        ii=1
        do i=1,nbf
           jj=p(i)
           p(i)=ii
           ii=jj+ii
        enddo
        do i=1,nbb
            jj=abs(ibndry(5,i))
            q(i)=p(jj)
            p(jj)=p(jj)+1
        enddo
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
c
c
        do i=1,nbb
           p(q(i))=i
        enddo
        do i=nbb+1,newnbf
            p(i)=i
        enddo
        do i=newnbf+1,nbi
           p(q(i))=i
        enddo
        do i=nbi+1,nbf
            p(i)=i
        enddo
        call border(ip,p,q,ibndry,sf)
c
c       collect interface edges in consecutive entries
c
        if(nbb>0) 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 12.0 - - - june, 2016
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)<itnode(4,i)) then
                        ibndry(1,k)=itnode(index(2,jj),ii)
                        ibndry(2,k)=itnode(index(3,jj),ii)
                    endif
                endif
                if(ibndry(3,k)<0.and.ibndry(1,k)/=ibsv) then
                    sfsv=sf(1,k)
                    sf(1,k)=sf(2,k)
                    sf(2,k)=sfsv
                endif
            enddo
        enddo
c
c
        do i=1,nbf
            p(i)=i
        enddo
        nbisv=nbi
        do ii=nbisv+1,nbf
            i=p(ii)
            if(ibndry(4,i)==0) then
                k1=ibedge(1,i)/4
                k2=ibedge(2,i)/4
                k1rgn=itnode(4,k1)
                k2rgn=itnode(4,k2)
                if(k1rgn/=k2rgn) then
                    nbi=nbi+1
                    p(i)=p(nbi)
                    p(nbi)=i
                endif
            else if(ibndry(4,i)<0) then
                k1=ibedge(1,i)/4
                j=-ibndry(4,i)
                k2=ibedge(1,j)/4
                k1rgn=itnode(4,k1)
                k2rgn=itnode(4,k2)
                ksw=0
                if(irgn==k1rgn) ksw=1
                if(irgn==k2rgn) ksw=1
                if(k1rgn>=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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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(kson<len) then
            if(list(p(kson+1))>list(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 12.0 - - - june, 2016
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)<itree(1,j)) then
                itree(1,next)=itree(1,i)
                itree(2,next)=itree(2,j)
                itree(3,next)=i
                itree(4,next)=j
                if(itree(2,i)+1/=itree(1,j)) stop 4411
            else
                itree(1,next)=itree(1,j)
                itree(2,next)=itree(2,i)
                itree(3,next)=j
                itree(4,next)=i
                if(itree(1,i)/=itree(2,j)+1) stop 4422
            endif
            list(next)=list(i)/2
            if(list(i)/2/=list(j)/2) stop 4433
            k=q(next)
            call updhpi(k,last,p,q,list,1_iknd)
            next=next+1
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine spth(nproc,irgn,mxpth,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(6,mxpth) :: ipath0
cy
c       order irgn last in ipath
c
        do i=1,ipath(2,nproc+2)
            do j=1,6
                ipath0(j,i)=ipath(j,i)
            enddo
        enddo
c
c
        ipath(2,nproc+2)=ipath(1,nproc+2)-1
        do i=1,nproc
            if(i==irgn) cycle
            ipath(1,i)=ipath(2,nproc+2)+1
            jb0=ipath(1,i)-ipath0(1,i)
            ipath(2,i)=ipath0(2,i)+jb0
            ipath(2,nproc+2)=ipath(2,i)
c
            do j=ipath(1,i),ipath(2,i)
                do k=1,6
                    ipath(k,j)=ipath0(k,j-jb0)
                enddo
                if(ipath(2,j)>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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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(j<i) cycle
c
c       mark equivalent dofs
c
            call l2gmpe(i,ibedge,iord,idof,itdof)
            call l2gmpe(j,ibedge,iord,jdof,itdof)
            do mm=1,iord+1
                iv=idof(mm)
                jv=jdof(iord+2-mm)
                it=iv
   40           it=iequv(it)
                if(it==jv) cycle
                if(it/=iv) go to 40
                it=iequv(iv)
                iequv(iv)=iequv(jv)
                iequv(jv)=it
            enddo
        enddo
c
c       make all equivalent vertices point at a smallest member
c
        do i=1,ndf
            if(iequv(i)<=0) cycle
            num=1
            imin=i
            next=i
   70       next=iequv(next)
            if(next/=i) then
                imin=min(imin,next)
                num=num+1
                go to 70
            endif
            last=imin
            do k=1,num
                next=iequv(last)
                iequv(last)=-imin
                last=next
            enddo
        enddo
        do i=1,ndf
            iequv(i)=-iequv(i)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine setgr2(ip,itnode,itdof,ir0,ja0,maxja0,iflag)
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), dimension(3) :: iords
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(maxja0) :: link,val
            integer(kind=iknd), dimension(100) :: idof
cy
c       construct interface ir0/ja0
c
        iflag=1
        ntf=ip(1)
        newndf=ip(30)
        ndd=ip(33)
        ndi=ip(36)
        irgn=ip(50)
        n=ndd+ndi-newndf
c
c       make linked list for ir0
c
        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
                if(idof(j)<=ndd) then
                    jrow=idof(j)
                else if(idof(j)<=newndf) then
                    jrow=0
                else if(idof(j)<=ndi) then
                    jrow=idof(j)-newndf+ndd
                else
                    jrow=0
                endif
                if(jrow==0) cycle
                ilink=link(jrow)
   10           if(ilink==0) then
                    if(next>maxja0) 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 12.0 - - - june, 2016
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<krgn) stop 1133
            call l2gpth(iseg,idof,ndof,ipath)
            call l2gpth(jseg,jdof,jndof,ipath)
            call l2gpth(kseg,kdof,kndof,ipath)
c           if(ndof/=jndof) stop 1134
c           if(ndof/=kndof) stop 1135
c
            if(ndof<jndof) then
                jdof(ndof)=jdof(jndof)
                kdof(ndof)=kdof(kndof)
            endif
c
c       note coarse part of ipath has dofs in actual ordering
c
            do mm=1,ndof
                ii=idof(mm)
                do k=ir0(ii),ir0(ii+1)-1
cc                  if(ir0(k)/n1==jrgn) map(k-n1)=jdof(mm)
cc                  if(ir0(k)/n1==krgn) map(k-n1)=kdof(ndof+1-mm)
                    if(ir0(k)/n1==jrgn) map(k-n1)=jdof(ndof+1-mm)
                    if(ir0(k)/n1==krgn) map(k-n1)=kdof(mm)
                enddo
            enddo
        enddo
c
c       fine interface (done last to avoid cross point problems)
c
        do iseg=ipath(1,irgn),ipath(2,irgn)
            if(ipath(2,iseg)>=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 12.0 - - - june, 2016
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<jj) then
            do ij=ja0(i),ja0(i+1)-1
                if(ja0(ij)==j) then
                    ji=ij+amtx0
                    return
                endif
            enddo
c
        else
            do ji=ja0(j),ja0(j+1)-1
                if(ja0(ji)==i) then
                    ij=ji+amtx0
                    return
                endif
            enddo
        endif
        stop 9721
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function i2j(i,jrgn,ndd,newndf,ir0)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ir0
            integer(kind=iknd) :: i2j
cy
c       jrgn > 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=j-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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine paste(maxt,maxv,maxb,maxpth,ip,itnode,ibndry,
     +      ipath,vx,vy,rl,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,iords,iv
            integer(kind=iknd), save, dimension(3) :: ibmptr,nref
            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), save, dimension(3) :: e,bump
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
            data nref/3*0/
            data ibmptr/3*0/
            data bump/3*0.0e0_rknd/
            data e/3*0.0e0_rknd/
c
c
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        ndf=ip(4)
        nrl=ip(13)
        nef=ip(76)
        ngf=ip(77)
        maxpth=ip(82)
cc      maxt=ip(83)
        nproc=ip(49)
        irgn=ip(50)
        mxlab=ipath(3,nproc+2)
        erth=0.0e0_rknd
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
        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,nrl,rl,
     1      maxv,maxt,maxb,maxd,gf,ngf,nef,nref,erth,
     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(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
c
c       improve  geometry of elements with interface edges
c
        do iseg=ipath(1,irgn),ipath(2,irgn)
            if(ipath(2,iseg)>0) cycle
            if(ipath(1,iseg)<=0) cycle
            ibdy=-ipath(2,iseg)
            do m=1,2
                itri=ibedge(m,ibdy)/4
                iedge=ibedge(m,ibdy)-4*itri
                call etst2(itri,iedge,isw,itnode,
     +              itedge,ibndry,ibedge,vx,vy)
                if(isw==2) cycle
                call newnot(itri,iedge,nvf,ntf,nbf,ndf,itnode,
     +              itedge,ibndry,ibedge,itdof,vx,vy,sf,nrl,rl,
     1              maxv,maxt,maxb,maxd,gf,ngf,nef,nref,erth,
     2              ibmptr,bump,p,q,e,0_iknd,incdf,iflag,sxy)
c
                if(iflag/=0) then
                    ip(25)=iflag
                    return
                endif
            enddo
        enddo
c
        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,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
        call mfe2(nvf,nbf,itmax,vx,vy,sf,iseed,vtype,
     +      itnode,itedge,ibndry,ibedge,sxy)
c
        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,
     +          ibndry,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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine paste1(maxt,maxp,maxb,nproc,ip,itnode,ibndry,
     +      vx,vy,rl,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,iords,iv
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), save, dimension(3) :: nref,ibmptr
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(maxd,*) :: gf
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), save, dimension(3) :: bump,e
            real(kind=rknd), dimension(10) :: rl
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/
            data nref/3*0/
            data ibmptr/3*0/
            data bump/3*0.0e0_rknd/
            data e/3*0.0e0_rknd/
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)
        nrl=ip(13)
        erth=0.0e0_rknd
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)<itnode(4,it)) then
            ii=ibedge(1,ibdy)
            ibedge(1,ibdy)=ibedge(2,ibdy)
            ibedge(2,ibdy)=ii
            jedge=ibedge(1,ibdy)-4*jt
            ibsv=ibndry(1,ibdy)
            ibndry(1,ibdy)=itnode(index(2,jedge),jt)
            ibndry(2,ibdy)=itnode(index(3,jedge),jt)
            if(ibndry(3,ibdy)<0.and.ibsv/=ibndry(1,ibdy)) then
                sfsv=sf(1,ibdy)
                sf(1,ibdy)=sf(2,ibdy)
                sf(2,ibdy)=sfsv
            endif
        endif
c
c       test for interface paths near irgn
c
        itri=ibedge(1,ibdy)/4
        i1=idist(itnode(4,itri))
        if(ibndry(4,ibdy)==0) then
            itri=ibedge(2,ibdy)/4
            i1=min(idist(itnode(4,itri)),i1)
        endif
        if(i1>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,nrl,rl,
     1      maxv,maxt,maxb,maxd,gf,ngf,nef,nref,erth,
     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(1),ip(2),ip(3),ip(4),ip(27),ip(28),ip(29),ip(30))
        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
        ip(1)=ntf
        ip(2)=nvf
        ip(3)=nbf
        ip(4)=ndf
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 70
c
        angmin=1.0e-3_rknd
        arcmax=0.26e0_rknd
        call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
        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,itedge,vtype,
     +          angmin,arcmax,vlist,tlist,elist,len)
            if(corner(vtype(i))==1) cycle
            kedge=iedge
   60       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 60
            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,nrl,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
   70   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(1),ip(2),ip(3),ip(4),ip(27),ip(28),ip(29),ip(30))
        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,ibndry,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(1),ip(2),ip(3),ip(4),ip(27),ip(28),ip(29),ip(30))
        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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine p2qdof(itri,iordc,iordsc,ndf,ngf,maxd,itedge,ibedge,
     +      ibndry,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(7,*) :: ibndry
            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(ibndry(4,ib)>0) then
                    jadj(j)=0
                    jedge(j)=0
                else if(ibndry(4,ib)==0) then
                    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
                else
                    jj=-ibndry(4,ib)
                    jadj(j)=ibedge(1,jj)/4
                    jedge(j)=ibedge(1,jj)-4*jadj(j)
                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
c
c       look for neighbor triangles to refine
c
        do j=1,3
            if(jadj(j)<=0) cycle
            if(iv(j)/=0) cycle
            if(jord(j)>=iordc) cycle
            num=0
            do k=1,3
                if(jords(k,j)>=iordc) num=num+1
            enddo
            if(num>=2) iv(j)=-jadj(j)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine newnot(itri,iedge,nvf,ntf,nbf,ndf,itnode,itedge,
     +      ibndry,ibedge,itdof,vx,vy,sf,nrl,rl,maxv,maxt,maxb,maxd,gf,
     1      ngf,nef,nref,erth,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(10) :: mxref
            integer(kind=iknd), save, dimension(4) :: it,ib,iv
            integer(kind=iknd), dimension(*) :: p,q,ibmptr,nref
            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(2,15) :: values
            real(kind=rknd), dimension(100) :: gv
            real(kind=rknd), dimension(10) :: rl
            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/
            data mxref/9,5,4,3,2,2,2,2,2,2/
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
        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,2+nrl
                values(1,k)=0.0e0_rknd
                values(2,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,1)
            vy(nvf)=values(2,1)
        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,2+nrl
                values(1,k)=0.0e0_rknd
                values(2,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,1)
            vy(nvf-1)=values(2,1)
        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
            if(nref(jtri)==0) erth=erth+e(jtri,1)
            nref(jtri)=nref(jtri)+1
            nref(ntf1)=nref(jtri)
            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.and.nref(jtri)<mxref(jord)) then
                call tqual(jtri,itnode,vx,vy,ibmptr,bump,itdof,
     +              nef,ej,e2)
                call tqual(ntf1,itnode,vx,vy,ibmptr,bump,itdof,
     +              nef,ee,e2)
            else
                ej=0.0e0_rknd
                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)
            e(jtri,1)=ej
            kk=q(jtri)
            call updhp(kk,ntf1,p,q,e,1_iknd)
        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
            if(nref(itri)==0) erth=erth+e(itri,1)
            nref(itri)=nref(itri)+1
            nref(ntf)=nref(itri)
            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.and.nref(itri)<mxref(iord)) then
                call tqual(itri,itnode,vx,vy,ibmptr,bump,itdof,
     +              nef,ei,e2)
                call tqual(ntf,itnode,vx,vy,ibmptr,bump,itdof,
     +              nef,ee,e2)
            else
                ei=0.0e0_rknd
                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)
            e(itri,1)=ei
            kk=q(itri)
            call updhp(kk,ntf,p,q,e,1_iknd)
        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 12.0 - - - june, 2016
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)<h(2)) iedge=2
        if(h(iedge)<h(3)) iedge=3
        itsv=itri
        iesv=iedge
        isw=1
c***    if(isw==1) return
c
c       find out whats on other side
c
        ibdy=-itedge(iedge,itri)
        if(ibdy<0) then
            jtri=itedge(iedge,itri)/4
            jedge=itedge(iedge,itri)-4*jtri
        else if(ibndry(4,ibdy)>0) then
            return
        else if(ibndry(4,ibdy)==0) then
            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
            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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine etst2(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), dimension(3) :: jtri,jedge,jrgn
            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=2   dont refine
c
c       refine elements with interface edges as needed to
c       make the dd solver efficient.
c
        isw=2
        irgn=itnode(4,itri)
c
c       determine the neighbor situation for element itri
c
        do j=1,3
            j2=index(2,j)
            j3=index(3,j)
            h(j)=(vx(j2)-vx(j3))**2+(vy(j2)-vy(j3))**2
            ibdy=-itedge(j,itri)
            if(ibdy<0) then
                jtri(j)=itedge(j,itri)/4
                jedge(j)=itedge(j,itri)-4*jtri(j)
                jrgn(j)=itnode(4,jtri(j))
                if(jrgn(j)==irgn) jrgn(j)=0
            else if(ibndry(4,ibdy)>0) then
                jtri(j)=0
                jedge(j)=0
                jrgn(j)=0
            else if(ibndry(4,ibdy)==0) then
                if(ibedge(1,ibdy)/4/=itri) then
                    jtri(j)=ibedge(1,ibdy)/4
                    jedge(j)=ibedge(1,ibdy)-4*jtri(j)
                else
                    jtri(j)=ibedge(2,ibdy)/4
                    jedge(j)=ibedge(2,ibdy)-4*jtri(j)
                endif
                jrgn(j)=itnode(4,jtri(j))
                if(jrgn(j)==irgn) jrgn(j)=0
            else
                jbdy=-ibndry(4,ibdy)
                jtri(j)=ibedge(1,jbdy)/4
                jedge(j)=ibedge(1,jbdy)-4*jtri(j)
                jrgn(j)=itnode(4,jtri(j))
                if(jrgn(j)==irgn) jrgn(j)=0
            endif
        enddo
c
c       find longest edge of itri, and determine interface edges
c
        i2=0
        i3=0
        num=0
        kedge=iedge
        do j=1,3
            if(h(j)>h(iedge)) iedge=j
            if(jrgn(j)/=0) then
                num=num+1
                i3=i2
                i2=j
            endif
        enddo
c
        if(num==1) then
c
c       if interface edge is longest dont refine
c
            if(iedge==kedge) return
            thresh=0.7e0_rknd
        else if(num==2) then
c
c       the most dangerous case, esp if near crosspoint
c
            if(iedge==kedge.and.jrgn(i2)==jrgn(i3)) return
            iedge=6-i2-i3
            thresh=0.5e0_rknd
        else if(num==3) then
            return
        else
            stop 4545
        endif
c
c       test potential iedge
c
        j=iedge
        if(jtri(j)>0) then
            j1=itnode(jedge(j),jtri(j))
            j2=itnode(index(2,jedge(j)),jtri(j))
            j3=itnode(index(3,jedge(j)),jtri(j))
            h(1)=(vx(j2)-vx(j3))**2+(vy(j2)-vy(j3))**2
            h(2)=(vx(j3)-vx(j1))**2+(vy(j3)-vy(j1))**2
            h(3)=(vx(j1)-vx(j2))**2+(vy(j1)-vy(j2))**2
            if(h(1)>=thresh*max(h(2),h(3))) isw=1
        else
            isw=1
        endif
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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(4)=newndf
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
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)<itc(mxord+1).and.itc(i+1)==itc(mxord+1))
     +              maxord=i
            enddo
            if(maxord==minord) jtype=1
c
c           initialize
c
            do it=1,ntf
                call locord(it,ndof,iord,iords,itdof)
                itldof(4,itc(iord))=it
                itc(iord)=itc(iord)+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
                    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) then
                last=next
                mark(itldof(4,next))=0
                go to 10
            endif
        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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cbump(ndl,ntf,nbf,maxt,maxd,nef,u,vx,vy,itnode,
     +      itedge,ibedge,itldof,nblock,iblock,ibndry,itdof,
     1      ibmptr,bump,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(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(maxd,*) :: u
            real(kind=rknd), dimension(maxt,*) :: e
            real(kind=rknd), dimension(ndl,10) :: r,r0
            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(20) :: er
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       compute recovered gradient
c
        mxcg=50
        mxsmth=1
        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
        ibmptr(1)=1
        do i=1,ntf
            call locord(i,ndof,iord,iords,itdof)
            ibmptr(i+1)=ibmptr(i)+(iord+2)*nef
            e(i,2)=0.0e0_rknd
        enddo
c
c       compute mass and stiffness matrices for linear elements
c       mark boundary points
c
        maxlnk=ndl*4
        call setgr1(ntl,ndl,itldof,ja,maxlnk,0_iknd,jflag)
        call l2mtx(ndl,vx,vy,itnode,ja,a2,itldof,ntl)
        if(mxsmth>0) then
            call h1mtx(ndl,vx,vy,itnode,ja,a1,itldof,ntl)
            do i=1,ndl
                ibc(i)=0
            enddo
            do i=1,ntl
                itri=itldof(4,i)
                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
                    else
                        jtri=itedge(j,itri)/4
                        call locord(jtri,ndof,jord,jords,itdof)
                        if(jord/=iord) then
                            ibc(itldof(index(2,j),i))=1
                            ibc(itldof(index(3,j),i))=1
                        endif
                    endif
                enddo
            enddo
        endif
c
        do ifn=1,nef
            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
                        r0(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,itdof,
     +                      vx,vy,u(1,ifn),er)
                        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,itdof,
     +                      vx,vy,u(1,ifn),er)
                    endif
                    do k=1,ldof
                        do j=1,iord+1
                            if(er(j)>0.0e0_rknd) then
                                r(idof(k),j)=r(idof(k),j)+er(j)
                            else
                                r0(idof(k),j)=r0(idof(k),j)+er(j)
                            endif
                        enddo
                    enddo
                enddo
c
c       l2 projection and smoothing
c
                do j=1,iord+1
                    do i=n1,n2
                        rr=r(i,j)+r0(i,j)
                        if(abs(rr)<eps*(r(i,j)-r0(i,j))) then
                            r(i,j)=0.0e0_rknd
                        else
                            r(i,j)=rr
                        endif
                    enddo
                    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
                    call sgscg1(ndl,n1,n2,ja,a2,r(1,j),z,mxcg,eps)
c**                 call jcg1(ndl,n1,n2,ja,a2,r(1,j),z,mxcg,eps)
                    if(mxsmth>0) then
                        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
                    else
                        do i=n1,n2
                            r(i,j)=r(i,j)*rscale
                        enddo
                    endif
                enddo
c
c       compute bump array
c
                do it=it1,it2
                    itri=itldof(4,it)
                    call locord(itri,ndof,jord,jords,itdof)
                    if(jord/=iord) cycle
                    ii=ibmptr(itri)+(ifn-1)*(iord+2)
                    call tqualr(it,iord,itnode,vx,vy,u(1,ifn),
     +                  ndl,r,itdof,itldof,bump(ii),aa)
                    e(itri,2)=max(e(itri,2),aa)
                enddo
            enddo
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cdlfn(ndf,ip,itnode,itdof,udl,ja,ibs,ibp,ibo,
     +      a,da,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,da
            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
c
        if(method==1) then
            call sfbilu(ndf,nb,ja,a,ibs,maxju,jua,
     +          maxu,ua,ispd,dtol,0_iknd)
        else
            call sfhb(nb,ja,jp,ibs,ibo,a,da,maxju,
     +          juac,maxu,uac,ispd,dtol,0_iknd,method)
        endif
c
        call mg(ndf,nb,ispd,method,mxcg,0_iknd,epsmg,ja,
     +      a,da,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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine usrfn(ntf,itnode,itdof,vx,vy,ngf,rl,maxd,u,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(5) :: iptr
            integer(kind=iknd), dimension(8,*) :: itdof
            real(kind=rknd), dimension(*) :: vx,vy,uu
            real(kind=rknd), dimension(maxd,*) :: u
            real(kind=rknd), dimension(4,100) :: gv
            real(kind=rknd), dimension(3,100) :: c
            real(kind=rknd), dimension(10) :: rl
            common /pltmg1/ic(3,363),jc(12)
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
        do it=1,ntf
            call l2gmap(it,idof,ndof,iord,iords,itdof)
            call mkgptr(iord,iords,iptr)
            do i=1,3
                ii=jc(iord)+i-1
                do j=1,3
                    c(j,i)=real(ic(j,ii),rknd)/real(iord,rknd)
                enddo
            enddo
            do iside=1,3
                is=iords(iside)
                if(is<=1) cycle
                do i=1,is-1
                    ki=jc(is)+2+(is-1)*(iside-1)+i
                    kc=iptr(iside)+i-1
                    do j=1,3
                        c(j,kc)=real(ic(j,ki),rknd)/real(is,rknd)
                    enddo
                enddo
            enddo
            if(iord>2) then
                ii=((iord-1)*(iord-2))/2
                do i=1,ii
                    ki=jc(iord)+iord*3+i-1
                    kc=iptr(4)+i-1
                    do j=1,3
                        c(j,kc)=real(ic(j,ki),rknd)/real(iord,rknd)
                    enddo
                enddo
            endif
c
            call eleufn(it,itnode,vx,vy,maxd,ngf,u,rl,
     +          ndof,gv,c,itdof,qxy)
            do i=1,ndof
                uu(idof(i))=gv(4,i)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine eswapa(ntf,nvf,nbf,ngf,nef,itnode,itedge,ibndry,
     +      ibedge,vx,vy,ibmptr,bump,maxt,e,isw,ksw,itdof,maxd,gf)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(nvf) :: deg
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(3) :: iseed,iords,kords
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(*) :: ibmptr
            real(kind=rknd), dimension(*) :: vx,vy,bump
            real(kind=rknd), dimension(maxt,*) :: e
            real(kind=rknd), save, dimension(5) :: fract0,qmin0
            real(kind=rknd), dimension(maxd,*) :: gf
cy
            data index/1,2,3,2,3,1,3,1,2/
            data fract0/1.0e0_rknd,1.0e0_rknd,
     +          0.95e0_rknd,0.9e0_rknd,1.0e0_rknd/
            data qmin0/1.0e0_rknd,0.95e0_rknd,
     +          0.87e0_rknd, 0.6e0_rknd,0.95e0_rknd/
c
c
c       this routine swaps interior triangle edges in an attempt
c       to improve the overall quality of the triangulation
c
c       this version incoporporates ideas of field for equilibrating degrees
c
        itmax=2
c
c       compute psuedo degrees for boundary vertices
c
        do i=1,nvf
            deg(i)=0
        enddo
c
        do i=1,nbf
            if(ibndry(4,i)==0) cycle
            kv=ibndry(1,i)
            kb=ibndry(2,i)
            kedge=ibedge(1,i)
   20       kt=kedge/4
            ke=kedge-4*kt
            kedge=itedge(index(3,ke),kt)
            if(kedge>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(mtst<ithrsh.and.ithrsh<5) cycle
c
                        ii=-itedge(index(ied,2),i)
                        jj=-itedge(index(ked,3),k)
                        if(min(ii,jj)>0) 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(q23<min(qik*fract,qmin)) cycle
c
c       swap edges
c
                        ichng=ichng+1
                        deg(j2)=deg(j2)-1
                        deg(j3)=deg(j3)-1
                        deg(mi)=deg(mi)+1
                        deg(mk)=deg(mk)+1
c
                        call eleswp(i,ied,itnode,itedge,ibedge,
     +                      itdof,ngf,maxd,gf,nef,ibmptr,bump,
     1                      maxt,e,iseed,vx,vy,isw,0_iknd,ksw)
                    enddo
                enddo
            if(ichng<=0) exit
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine eleswp(itri,iedge,itnode,itedge,ibedge,itdof,
     +      ngf,maxd,gf,nef,ibmptr,bump,maxt,e,iseed,vx,vy,isw,jsw,ksw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(*) :: iseed,ibmptr
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(100) :: idof0,idof1
            integer(kind=iknd), dimension(100) :: kdof0,kdof1
            integer(kind=iknd), dimension(5) :: iptr0,iptr1
            integer(kind=iknd), dimension(5) :: kptr0,kptr1
            integer(kind=iknd), dimension(3) :: iords0,iords1
            integer(kind=iknd), dimension(3) :: kords0,kords1
            integer(kind=iknd), dimension(20,20) :: map0,map1
            integer(kind=iknd), dimension(8) :: it0,kt0
            real(kind=rknd), dimension(*) :: bump,vx,vy
            real(kind=rknd), dimension(maxt,*) :: e
            real(kind=rknd), dimension(maxd,*) :: gf
            real(kind=rknd), dimension(10,10) :: gtmp
            common /pltmg1/ic(3,363),jc(12)
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       elementary edge swap
c
        ktri=itedge(iedge,itri)/4
        kedge=itedge(iedge,itri)-4*ktri
        ie2=index(2,iedge)
        ie3=index(3,iedge)
        ke2=index(2,kedge)
        ke3=index(3,kedge)
c
        if(itnode(4,itri)/=itnode(4,ktri)) stop 6016
        if(itnode(5,itri)/=itnode(5,ktri)) stop 6006
c
        itnode(ie2,itri)=itnode(kedge,ktri)
        itnode(ke2,ktri)=itnode(iedge,itri)
        itedge(iedge,itri)=itedge(ke3,ktri)
        itedge(kedge,ktri)=itedge(ie3,itri)
        itedge(ie3,itri)=4*ktri+ke3
        itedge(ke3,ktri)=4*itri+ie3
c
c       fixup neighboring elements
c
        ltri=itedge(iedge,itri)/4
        if(ltri>0) 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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tgen(ntf,maxt,maxv,ip,rp,vx,vy,rl,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
            real(kind=rknd), dimension(10) :: rl
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)
        nrl=ip(13)
c
c
        iflag=0
c       set up parameters
c       rp(12) = hmax
c       rp(13) = grade
c       rp(76) = qual
c       rp(77) = angmn
c       rp(78) = diam
c       rp(79) = best
c
        if(rp(12)<=0.0e0_rknd.or.rp(12)>1.0e0_rknd) rp(12)=1.0e0_rknd
        rp(13)=max(1.5e0_rknd,rp(13))
        rp(13)=min(2.5e0_rknd,rp(13))
        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(16),rp(18),rp(78),
     +      nrl,rl,sxy)
c
c       refine boundary edges
c
        call lngedg(ntr,nvr,nbr,maxv,maxb,rp,vx,vy,sf,
     +      itnode,ibndry,iflag,nrl,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,nrl,rl,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,nrl,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 12.0 - - - june, 2016
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<ns0) return
            go to 5
        endif
        go to 10
c
c       triangulate the remaining convex polygon
c       by adding one knot at the centroid
c
   80   call ccnvx(ns,nvr,ntr,maxv,vx,vy,itnode,irptr,ipoly,iflag)
        if(iflag/=0) return
        ns=ns-1
        if(ns<ns0) return
        go to 5
c
c       make jlink-klink link...add necessary vertices and adjust regions
c
   90   call clink(jlink,klink,ns,nvr,maxv,ntr,
     +      vx,vy,ipoly,irptr,itnode,itedge,rp,iflag)
        if(iflag/=0) return
        go to 5
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine csym(nsr,ns,nvr,ntr,maxv,vx,vy,itnode,itedge,
     +      ipoly,irgn,itptr,ivptr,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,irgn
            integer(kind=iknd), dimension(*) :: itptr,ivptr,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
c       triangluate a region similar to a previously triangulated region
c
        iflag=0
        tol=(1.0e1_rknd*epsilon(1.0e0_rknd)*rp(78))**2
        nso=abs(irgn(3,ns))
        if(nso==0.or.nso>=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 12.0 - - - june, 2016
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<i) cycle
            do mm=1,2
                iv=ibndry(mm,i)
                jv=ibndry(3-mm,j)
                it=iv
   10           it=iequv(it)
                if(it==jv) cycle
                if(it/=iv) go to 10
                it=iequv(iv)
                iequv(iv)=iequv(jv)
                iequv(jv)=it
            enddo
        enddo
c
c       set up equivalence classes for vertices
c
        do ns=1,ntr
            if(itnode(3,ns)==0) cycle
            nso=abs(itnode(3,ns))
            if(nso>=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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sethl(nvr,nbr,ntr,maxv,maxb,vx,vy,
     +      sf,itnode,ibndry,rp,llist,iflag,nrl,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*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
            real(kind=rknd), dimension(10) :: rl
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(13)
        hmax=rp(78)*rp(12)
        num=16
c
c       compute jb
c
        call makjb(nvr,nbr,ntr,vx,vy,sf,ibndry,itnode,1_iknd,jb,
     +      iflag,nrl,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(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,nrl,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,nrl,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,nrl,rl,sxy)
                r=((grade-1.0e0_rknd)*d+hloc(iequv(iv)))/grade
                if(r<hloc(iequv(jv))) then
                    ratio=max(ratio,hloc(iequv(jv))/r)
                    hloc(iequv(jv))=r
                endif
            enddo
c
c        now check edge-vertex pairs
c
            if(ratio-1.0e0_rknd<=tol.and.ncount<=0) exit
            do i=1,ncount
                kv=list(1,i)
                ie1=list(2,i)
                iv=ibndry(1,ie1)
                jv=ibndry(2,ie1)
                if(hloc(iequv(iv))>hloc(iequv(jv))) then
                    iv=jv
                    jv=ibndry(1,ie1)
                endif
                q(1)=vx(kv)
                q(2)=vy(kv)
                dp(1)=(vx(jv)-vx(iv))/2.0e0_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,nrl,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<hloc(iequv(jv))) then
                    ratio=max(ratio,hloc(iequv(jv))/r)
                    hloc(iequv(jv))=r
                endif
                hb=hloc(iequv(iv))+fr*(hloc(iequv(jv))-hloc(iequv(iv)))
                ht=hloc(iequv(kv))
                if(ht<hb) then
c
c       the case where hloc on the edge (iv,jv) is bigger
c
                    r=((grade-1.0e0_rknd)*z+ht)/grade
                    r=min(r,z)
                    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(r<ht) then
                        ratio=max(ratio,hloc(iequv(kv))/r)
                        hloc(iequv(kv))=r
                    endif
                endif
            enddo
            if(ratio-1.0e0_rknd<=tol) exit
        enddo
        do i=1,nvr
            hloc(i)=hloc(iequv(i))
        enddo
c
c       refine original edges
c
        call invv(ntr,nvr,nbr,maxv,maxb,vx,vy,hloc,sf,rp,
     +      ibndry,itnode,iflag,nrl,rl,sxy)
        return
  200   iflag=86
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine invv(ntr,nvr,nbr,maxv,maxb,vx,vy,hloc,sf,rp,
     +      ibndry,itnode,iflag,nrl,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(maxb) :: list
            real(kind=rknd), dimension(*) :: vx,vy,hloc
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(20) :: x,y,fi
            real(kind=rknd), dimension(2,15) :: values
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
c
c       divide user specified edges
c
        iflag=0
        pi=3.141592653589793e0_rknd
        num=16
        nbr0=nbr
        do i=1,nbr0
            list(i)=nbr+1
            j1=ibndry(1,i)
            j2=ibndry(2,i)
c
            call arclen(i,ibndry,1_iknd,sf,vx,vy,d,theta1,
     +          theta2,radius,num,x,y,fi,nrl,rl,sxy)
            call dvpram(hloc(j1),hloc(j2),d,rp,al,h,np)
c
            if(np<=0) cycle
            if(nvr+np>maxv) 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,2+nrl
                        values(1,k)=0.0e0_rknd
                        values(2,k)=0.0e0_rknd
                    enddo
                    call sxy(rl,sm,itag,values)
                    nvr=nvr+1
                    vx(nvr)=values(1,1)
                    vy(nvr)=values(2,1)
                    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 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mktri0(ntr,nvr,nbr,vx,vy,sf,ibndry,irptr,
     +      itnode,itedge,maxt,irgn,iflag,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3*nbr) :: jb
            integer(kind=iknd), dimension(5,*) :: itnode,irgn
            integer(kind=iknd), dimension(*) :: irptr
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(nbr) :: list
            integer(kind=iknd), dimension(nvr+nbr) :: vindex
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
            data index/1,2,3,2,3,1,3,1,2/
c
c       make a crude triangulation of the skeleton
c
        iflag=0
c
c       make jb
c
        call makjb(nvr,nbr,ntr,vx,vy,sf,ibndry,itnode,1_iknd,jb,
     +      iflag,nrl,rl,sxy)
        if(iflag/=0) return
c
        irptr(1)=maxt
        do itag=ntr,1,-1
            nb1=jb(itag)
            nb2=jb(itag+1)-1
            ie1=jb(nb1)
            ie2=jb(nb2)
            ivc=ibndry(1,ie1)
            if(ivc/=ibndry(1,ie2).and.ivc/=ibndry(2,ie2))
     +          ivc=ibndry(2,ie1)
            nn=0
            do jj=nb1,nb2
                it=jb(jj)
                ivn=ibndry(1,it)+ibndry(2,it)-ivc
                nn=nn+1
                vindex(nn)=ivc
                ivc=ivn
            enddo
            j4tag=irgn(4,itag)
            j5tag=irgn(5,itag)
            irptr(ntr-itag+2)=irptr(ntr-itag+1)-nn+2
            nt1=irptr(ntr-itag+2)+1
            nt2=irptr(ntr-itag+1)
            ntt=nt1-1
            call trisk(nn,vx,vy,vindex,ntt,itnode,j4tag,j5tag)
            call cedgek(nvr,nt1,nt2,nb1,nb2,itnode,ibndry,itedge,jb)
            call eswapk(nt1,nt2,itnode,itedge,vx,vy)
        enddo
c
c       determine boundary and internal interface edges
c
        do i=1,nbr
            if(ibndry(4,i)/=0) then
                list(i)=1
            else
                list(i)=0
            endif
        enddo
        do i=1,ntr
            ie1=jb(i)
            ie2=jb(i+1)-1
            do k=ie1,ie2
                j=jb(k)
                if(list(j)<0) then
                    m=-list(j)
                    if(irgn(5,m)/=irgn(5,i)) list(j)=1
                else if(list(j)==0) then
                    list(j)=-i
                endif
            enddo
        enddo
c
c       set up final form of ibndry by removing interior edges
c
        nbr0=nbr
        nbr=0
        do i=1,nbr0
            if(list(i)<=0) then
                jb(i)=0
            else
                nbr=nbr+1
                jb(i)=nbr
                do j=1,7
                    ibndry(j,nbr)=ibndry(j,i)
                enddo
                do j=1,2
                    sf(j,nbr)=sf(j,i)
                enddo
            endif
        enddo
c
        do i=1,nbr
            if(ibndry(4,i)>=0) cycle
            k=-ibndry(4,i)
            ibndry(4,i)=-jb(k)
        enddo
c
c       fixup itedge to refect ibndry update, orient ibndry
c
        do i=nt1,maxt
            do j=1,3
                k=-itedge(j,i)
                if(k<=0) cycle
                itedge(j,i)=-jb(k)
                if(jb(k)<=0) cycle
                m=jb(k)
                ibsv=ibndry(1,m)
                ibndry(1,m)=itnode(index(2,j),i)
                ibndry(2,m)=itnode(index(3,j),i)
                if(ibndry(3,m)<0.and.ibndry(1,m)/=ibsv) then
                    sfsv=sf(1,m)
                    sf(1,m)=sf(2,m)
                    sf(2,m)=sfsv
                endif
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tswap(it1,it2,itnode,itedge)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(3) :: iadj1,iadj2
cy
c       swap triangles it1 and it2
c
c       first fix up itedge (must be careful to handle case when
c       it1 and it2 are neighbors correctly)
c
        if(it1==it2) return
        do j=1,3
            iadj1(j)=itedge(j,it1)
            iadj2(j)=itedge(j,it2)
        enddo
        do j=1,3
            if(iadj1(j)>0) then
                kt=iadj1(j)/4
                ke=iadj1(j)-4*kt
                itedge(ke,kt)=4*it2+j
            endif
            if(iadj2(j)>0) then
                kt=iadj2(j)/4
                ke=iadj2(j)-4*kt
                itedge(ke,kt)=4*it1+j
            endif
        enddo
        do j=1,5
            k=itnode(j,it1)
            itnode(j,it1)=itnode(j,it2)
            itnode(j,it2)=k
        enddo
        do j=1,3
            k=itedge(j,it1)
            itedge(j,it1)=itedge(j,it2)
            itedge(j,it2)=k
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tchop(ichop,kv,vx,vy,rp,ipoly)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(3,*) :: ipoly
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(100) :: rp
cy
c       this routine decides whether it is a good idea to
c       chop off the triangle it
c
        qual=rp(76)
        best=rp(79)
        ichop=0
c
c       find vertex to chop
c
        ka=ipoly(1,kv)
        kb=ipoly(2,kv)
        it=ipoly(3,kv)/4
        if(it/=ipoly(3,kb)/4) return
c
c       check geometry
c
        gg=geom(kb,kv,ka,vx,vy)
        currnt=min(1.0e0_rknd,gg/qual)
        if(currnt<=best) return
        ichop=1
        if(currnt<1.0e0_rknd) ichop=-1
        rp(79)=currnt
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cchop(kv,ntr,ns,irptr,itnode,itedge,ipoly)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(*) :: irptr
            integer(kind=iknd), dimension(3,*) :: itedge,ipoly
            integer(kind=iknd), save, dimension(3,3) :: index
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       chop off triangle it
c
        it1=irptr(ns+1)+1
        irptr(ns+1)=it1
        it2=irptr(ns)
        it=ipoly(3,kv)/4
        if(it<it1.or.it>it2) stop 1093
        call tswap(it1,it,itnode,itedge)
        ntr=ntr+1
        do j=1,5
            itnode(j,ntr)=itnode(j,it1)
        enddo
        do j=1,3
            if(itedge(j,it1)<=0) cycle
            k=itedge(j,it1)/4
            ke=itedge(j,it1)-4*k
            itedge(ke,k)=0
c
            j1=itnode(index(2,ke),k)
            j2=itnode(index(3,ke),k)
            ipoly(1,j1)=j2
            ipoly(2,j2)=j1
            ipoly(3,j1)=4*k+ke
        enddo
        if(it>it1) then
            do j=1,3
                if(itedge(j,it)>0) cycle
                j1=itnode(index(2,j),it)
                ipoly(3,j1)=4*it+j
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tcnvx(icnvx,ns,irptr,itnode,vx,vy,rp,nvr,maxv,ipoly)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: irptr
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: ipoly
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(100) :: rp
cy
c       this routine checks if a convex region can be
c       triangulated by adding one vertex at the centriod
c
        icnvx=0
        it1=irptr(ns+1)+1
        it2=irptr(ns)
        num=it2-it1+3
        if(num>=7) return
        if(nvr+1>maxv) return
        qual=rp(76)
        best=rp(79)
        currnt=1.0e0_rknd
cc      if(num==7) currnt=0.9e0_rknd
cc      if(num==8) currnt=0.8e0_rknd
cc      if(currnt<=best) return
c
c       compute centroid
c
        kv=itnode(1,it1)
        x=0.0e0_rknd
        y=0.0e0_rknd
        do i=1,num
            x=x+vx(kv)
            y=y+vy(kv)
            kv=ipoly(1,kv)
        enddo
        nvr1=nvr+1
        vx(nvr1)=x/real(num,rknd)
        vy(nvr1)=y/real(num,rknd)
c
c       check geometry
c
        do i=1,num
            g=geom(kv,ipoly(1,kv),nvr1,vx,vy)
            currnt=min(currnt,g/qual)
            if(currnt<=best) return
            kv=ipoly(1,kv)
        enddo
        if(currnt<=0.0e0_rknd) return
        icnvx=1
        if(currnt<1.0e0_rknd) icnvx=-1
        rp(79)=currnt
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ccnvx(ns,nvr,ntr,maxv,vx,vy,itnode,irptr,ipoly,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: irptr
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: ipoly
            real(kind=rknd), dimension(*) :: vx,vy
cy
c       add centroid to convex region
c       list array computed in icnvx
c
        iflag=0
        it1=irptr(ns+1)+1
        it2=irptr(ns)
        num=it2-it1+3
        if(ntr+num>it2) then
            iflag=83
            return
        endif
        if(nvr+1>maxv) then
            iflag=84
            return
        endif
c
c       compute centroid
c
        kv=itnode(1,it1)
        x=0.0e0_rknd
        y=0.0e0_rknd
        do i=1,num
            x=x+vx(kv)
            y=y+vy(kv)
            kv=ipoly(1,kv)
        enddo
        nvr=nvr+1
        vx(nvr)=x/real(num,rknd)
        vy(nvr)=y/real(num,rknd)
c
c       make triangles
c
        jtag=itnode(4,it1)
        itag=itnode(5,it1)
        do i=1,num
            itnode(1,ntr+i)=kv
            itnode(2,ntr+i)=ipoly(1,kv)
            itnode(3,ntr+i)=nvr
            itnode(4,ntr+i)=jtag
            itnode(5,ntr+i)=itag
            kv=ipoly(1,kv)
        enddo
        ntr=ntr+num
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tlink(ilink,kv,kk,vx,vy,ipoly,rp,itnode,itedge)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(3,*) :: ipoly,itedge
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(100) :: rp
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       this routine determines the best point, if any, to
c       be linked with kv.  it is return in kk.
c
        angmn=rp(77)
        best=rp(79)
        angmin=1.0e0_rknd/20.0e0_rknd
        angmax=2.0e0_rknd-angmin
        ilink=0
c
c
        kk=0
        currnt=0.0e0_rknd
        ks=ipoly(1,kv)
        kf=ipoly(2,kv)
        xx=vx(kv)
        yy=vy(kv)
        kt=ipoly(3,kv)/4
        ke=ipoly(3,kv)-4*kt
   10   km=itnode(ke,kt)
        if(km/=kf) then
            jt=itedge(index(3,ke),kt)
            kt=jt/4
            ke=jt-4*kt
            kb=ipoly(2,km)
            ka=ipoly(1,km)
c
c       compute spacing
c
            dx=vx(km)-xx
            dy=vy(km)-yy
            dd=sqrt(dx*dx+dy*dy)
            hv=chloc(kf,kv,ks,vx,vy)
            hk=chloc(kb,km,ka,vx,vy)
            call dvpram(hv,hk,dd,rp,qa,ha,nps)
            if(nps==0) go to 10
c
c       compute angles
c
            a1=cang(km,kv,ks,vx,vy)
            a2=cang(kf,kv,km,vx,vy)
            a3=cang(kb,km,kv,vx,vy)
            a4=cang(kv,km,ka,vx,vy)
            aamin=min(a1,a2,a3,a4)
            aamax=max(a1,a2,a3,a4)
            if(aamin<angmin.or.aamax>angmax) go to 10
            testkm=min(1.0e0_rknd,aamin/angmn)
c
            if(ka==kf.or.kb==ks) testkm=testkm/2.0e0_rknd
            if(testkm>currnt) then
c
c       km is the best point found so far
c
                currnt=testkm
                kk=km
                if(currnt==1.0e0_rknd) go to 180
            endif
            go to 10
        endif
        if(kk==0) return
        if(currnt<=best) return
  180   ilink=1
        if(currnt<1.0e0_rknd) ilink=-1
        rp(79)=currnt
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine rlink(hl,hr,d,rp,xl,yl,xr,yr,vx,vy,nvr,maxv,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(*) :: vx,vy
cy
        iflag=0
        call dvpram(hl,hr,d,rp,alpha,h,np)
        if(np==0) return
        if(nvr+np>maxv) then
            iflag=84
            return
        endif
        if(np==0) return
        qq=0.0e0_rknd
        dx=xr-xl
        dy=yr-yl
        do i=1,np
            qq=qq+h
            h=h*alpha
            vx(nvr+i)=xl+qq*dx
            vy(nvr+i)=yl+qq*dy
        enddo
        nvr=nvr+np
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine clink(kv,kk,ns,nvr,maxv,ntr,
     +      vx,vy,ipoly,irptr,itnode,itedge,rp,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(3,*) :: ipoly,itedge
            integer(kind=iknd), dimension(*) :: irptr
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(2) :: p,dp,q,dq,al
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       add new point along the line connecting kv and kk
c
        iflag=0
        grade=rp(13)
        hmax=rp(78)*rp(12)
        it1=irptr(ns+1)+1
        it2=irptr(ns)
        num=it2-it1+3
        nvr0=nvr
c
c       compute points on linking line
c
        d=sqrt((vx(kv)-vx(kk))**2+(vy(kv)-vy(kk))**2)
        ka=ipoly(1,kk)
        kb=ipoly(2,kk)
        ks=ipoly(1,kv)
        kf=ipoly(2,kv)
        hk=chloc(kb,kk,ka,vx,vy)
        hv=chloc(kf,kv,ks,vx,vy)
c
c       see if increasing h towards the middle of the interval
c       is possible or worthwhile
c
        if(num<=8) go to 60
        if(d<=grade*(hv+hk)) go to 60
        ds=d*(grade-1.0e0_rknd)/grade
        theta=(hv-hk)/(2.0e0_rknd*ds)
        if(abs(theta)>0.4e0_rknd) go to 60
        fv=0.5e0_rknd-theta
        fk=0.5e0_rknd+theta
        hm=(ds+hv+hk)/2.0e0_rknd
        hmin=fv*hk+fk*hv
        hm=min(hm,hmax)
        if(hm<hmin) go to 60
c
c       set up lines
c
        xm=fv*vx(kk)+fk*vx(kv)
        ym=fv*vy(kk)+fk*vy(kv)
        p(1)=xm
        p(2)=ym
        dp(1)=vx(kk)-vx(kv)
        dp(2)=vy(kk)-vy(kv)
        dq(1)=-dp(2)
        dq(2)=dp(1)
        k=kk
        do i=1,num
            k=ipoly(1,k)
cc          if(k==ka.or.k==kb) cycle
cc          if(k==ks.or.k==kf) cycle
            if(k==kv.or.k==kk) cycle
            q(1)=vx(k)
            q(2)=vy(k)
            call lil(p,dp,q,dq,al,ier)
            if(al(1)<0.0e0_rknd) then
                al1=-al(1)/fv
                ht=hv
            else
                al1=al(1)/fk
                ht=hk
            endif
            if(al1>=1.0e0_rknd) cycle
            al2=abs(al(2))*ds
            if(al2>hm*(1.0e0_rknd-al1)) cycle
            hh=chloc(ipoly(2,k),k,ipoly(1,k),vx,vy)
            z=al2+hh/grade
            h=hm+(ht-hm)*al1
            if(h<=z) cycle
            hz=(z-al1*ht)/(1.0e0_rknd-al1)
            if(hz<=0.0e0_rknd) cycle
            hm=min(hm,hz)
            if(hm<hmin) go to 60
        enddo
c
c       first set up segment between kv and (xm,ym)
c
        dv=fv*d
        call rlink(hv,hm,dv,rp,vx(kv),vy(kv),xm,ym,
     +      vx,vy,nvr,maxv,iflag)
        if(iflag/=0) return
        if(nvr<maxv) then
            nvr=nvr+1
            vx(nvr)=xm
            vy(nvr)=ym
        else
            iflag=84
            return
        endif
c
c       next set up segment between (xm,ym) and kk
c
        dk=fk*d
        call rlink(hm,hk,dk,rp,xm,ym,vx(kk),vy(kk),
     +      vx,vy,nvr,maxv,iflag)
        if(iflag/=0) return
        go to 70
c
c       take h to be a linear function between kv and kk
c
   60   call rlink(hv,hk,d,rp,vx(kv),vy(kv),vx(kk),vy(kk),
     +      vx,vy,nvr,maxv,iflag)
        if(iflag/=0) return
c
c       find two triangles sharing the edge (kv,kk)
c
   70   kt=ipoly(3,kv)/4
        ke=ipoly(3,kv)-4*kt
   80   kz=itnode(ke,kt)
        if(kk/=kz) then
            jt=itedge(index(3,ke),kt)
            kt=jt/4
            ke=jt-4*kt
            go to 80
        endif
        ke=index(3,ke)
        jt=itedge(ke,kt)/4
        je=itedge(ke,kt)-4*jt
        newt=nvr-nvr0
        if(it1-2*newt<=ntr) then
            iflag=83
            return
        endif
        it0=it1-2*newt
c
        istart=it0
        nvr1=nvr0+1
        kn=itnode(ke,kt)
        kts=itedge(index(2,ke),kt)
        ktf=itedge(index(3,ke),kt)
c
        itnode(1,kt)=kv
        itnode(2,kt)=kn
        itnode(3,kt)=nvr1
        itedge(1,kt)=4*istart+3
        itedge(2,kt)=0
        itedge(3,kt)=kts
        if(kts>0) then
            mt=kts/4
            me=kts-4*mt
            itedge(me,mt)=4*kt+3
        endif
        do i=istart,istart+newt-1
            itnode(4,i)=itnode(4,kt)
            itnode(5,i)=itnode(5,kt)
            itnode(1,i)=nvr1+i-istart
            itnode(2,i)=kn
            if(i<istart+newt-1) then
                itnode(3,i)=itnode(1,i)+1
                itedge(1,i)=4*(i+1)+3
            else
                itnode(3,i)=kk
                itedge(1,i)=ktf
                if(ktf>0) then
                    mt=ktf/4
                    me=ktf-4*mt
                    itedge(me,mt)=4*i+1
                endif
            endif
            itedge(2,i)=0
            if(i>istart) then
                itedge(3,i)=4*(i-1)+1
            else
                itedge(3,i)=4*kt+1
            endif
        enddo
c
c
        istart=it0+newt
        nvr1=nvr
        kn=itnode(je,jt)
        kts=itedge(index(2,je),jt)
        ktf=itedge(index(3,je),jt)
c
        itnode(1,jt)=kk
        itnode(2,jt)=kn
        itnode(3,jt)=nvr1
        itedge(1,jt)=4*istart+3
        itedge(2,jt)=0
        itedge(3,jt)=kts
        if(kts>0) then
            mt=kts/4
            me=kts-4*mt
            itedge(me,mt)=4*jt+3
        endif
        do i=istart,istart+newt-1
            itnode(4,i)=itnode(4,jt)
            itnode(5,i)=itnode(5,jt)
            itnode(1,i)=nvr1+istart-i
            itnode(2,i)=kn
            if(i<istart+newt-1) then
                itnode(3,i)=itnode(1,i)-1
                itedge(1,i)=4*(i+1)+3
            else
                itnode(3,i)=kv
                itedge(1,i)=ktf
                if(ktf>0) then
                    mt=ktf/4
                    me=ktf-4*mt
                    itedge(me,mt)=4*i+1
                endif
            endif
            itedge(2,i)=0
            if(i>istart) then
                itedge(3,i)=4*(i-1)+1
            else
                itedge(3,i)=4*jt+1
            endif
        enddo
c
c       swap elements as necessary
c
        last=it0+newt-1
        icur=it0
   90   do j=1,3
           if(itedge(j,icur)<=0) cycle
           mt=itedge(j,icur)/4
           if(mt<=last) cycle
           last=last+1
           call tswap(last,mt,itnode,itedge)
        enddo
        icur=icur+1
        if(icur<=last) go to 90
c
c       finish setting up new regions
c
        irptr(ns+1)=last
        call eswapk(last+1,it2,itnode,itedge,vx,vy)
        ns=ns+1
        irptr(ns+1)=it0-1
        call eswapk(it0,last,itnode,itedge,vx,vy)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cedge2(nvr,nt1,nt2,nbf,itnode,itedge)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(nvr+nbf+3*(nt2-nt1+1)) :: list
            integer(kind=iknd), save, dimension(3,3) :: index
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       this routine makes a simple itedge array
c
        do i=1,nvr
            list(i)=0
        enddo
        llist=nvr+nbf+3*(nt2-nt1+1)
        iptr=nvr+1
        do i=iptr,llist,2
            list(i)=i+2
        enddo
        list(llist-1)=0
        list(llist-2)=0
c
c       first find adjacent triangles
c
        do i=nt1,nt2
            do j=1,3
                itedge(j,i)=0
            enddo
        enddo
        do i=nt1,nt2
            do j=1,3
                j2=index(2,j)
                j3=index(3,j)
                imax=max(itnode(j2,i),itnode(j3,i))
                imin=min(itnode(j2,i),itnode(j3,i))
                kold=imin
   40           k=list(kold)
                if(k<=0) then
c
c       add triangle i, edge j to list
c
                    if(iptr<=0) stop 7783
                    list(kold)=iptr
                    ii=iptr
                    iptr=list(iptr)
                    list(ii)=0
                    list(ii+1)=j+4*i
                else
c
c       check for a common edge
c
                    ii=list(k+1)/4
                    jj=list(k+1)-4*ii
                    j2=index(2,jj)
                    j3=index(3,jj)
                    iimax=max(itnode(j2,ii),itnode(j3,ii))
                    if(imax==iimax) then
                        itedge(j,i)=jj+4*ii
                        itedge(jj,ii)=j+4*i
                        list(kold)=list(k)
                        list(k)=iptr
                        iptr=k
                    else
                        kold=k
                        go to 40
                    endif
                endif
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine eswap(nt1,nt2,nvr,itnode,itedge,ipoly,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge,ipoly
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), save, dimension(4) :: qmin0,fract0
cy
            data index/1,2,3,2,3,1,3,1,2/
            data fract0/1.0e0_rknd, 1.0e0_rknd, 0.8e0_rknd, 0.6e0_rknd/
            data qmin0 /1.0e0_rknd, 1.0e0_rknd, 0.6e0_rknd, 0.3e0_rknd/
c
c
c       this routine swaps interior triangle edges in an attempt
c       to improve the overall quality of the triangulation
c
c       this version incoporporates ideas of field for equilibrating degrees
c
        itmax=3
c
c       initialize ipoly
c
        do i=1,nvr
            ipoly(3,i)=0
        enddo
        len=0
        do i=nt1,nt2
            do j=1,3
                if(itedge(j,i)>0) cycle
                j1=itnode(index(2,j),i)
                j2=itnode(index(3,j),i)
                ipoly(1,j1)=j2
                ipoly(2,j2)=j1
                len=len+1
            enddo
        enddo
c
c       compute psuedo degress for boundary vertices
c
        kv=j2
        do ii=1,len
            ka=ipoly(1,kv)
            kb=ipoly(2,kv)
            q=6.0e0_rknd-cang(kb,kv,ka,vx,vy)*3.0e0_rknd
            iq=max(int(q+0.5e0_rknd)-1,0_iknd)
            ipoly(3,kv)=min(5,iq)
            kv=ipoly(1,kv)
        enddo
c***    if(kv/=j2) call drgrdx(vx,vy,len,nt1,nt2,itnode)
        if(kv/=j2) stop 7423
c
c       compute degrees  in ipoly(3,*)
c
        do i=nt1,nt2
            do j=1,3
                k=itedge(j,i)/4
                if(i<=k) cycle
                j2=itnode(index(2,j),i)
                j3=itnode(index(3,j),i)
                ipoly(3,j2)=ipoly(3,j2)+1
                ipoly(3,j3)=ipoly(3,j3)+1
            enddo
        enddo
c
c       the main loop in which the edges are swapped
c
        do ithrsh=4,2,-1
            qmin=qmin0(ithrsh)
            fract=fract0(ithrsh)
            do itnum=1,itmax
                ichng=0
                do i=nt1,nt2
                    do ied=1,3
                        k=itedge(ied,i)/4
                        if(k<=0) cycle
                        ked=itedge(ied,i)-4*k
            if(k<nt1.or.k>nt2) stop 4321
                        j2=itnode(index(ied,2),i)
                        j3=itnode(index(ied,3),i)
                        mi=itnode(ied,i)
                        mk=itnode(ked,k)
c
c       dont connect two boundary points or increase high degrees
c
                        m1=max(itedge(index(ied,2),i),
     +                      itedge(index(ked,3),k))
                        m2=max(itedge(index(ked,2),k),
     +                      itedge(index(ied,3),i))
                        if(min(m1,m2)<=0) cycle
                        mtst=ipoly(3,j2)+ipoly(3,j3)
     +                      -ipoly(3,mi)-ipoly(3,mk)
                        if(mtst<ithrsh) cycle
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(q23<min(qik*fract,qmin)) cycle
c
c       swap edges
c
                        ichng=ichng+1
                        ipoly(3,j2)=ipoly(3,j2)-1
                        ipoly(3,j3)=ipoly(3,j3)-1
                        ipoly(3,mi)=ipoly(3,mi)+1
                        ipoly(3,mk)=ipoly(3,mk)+1
c
c
                        itnode(index(ied,3),i)=mk
                        itnode(index(ked,3),k)=mi
                        itedge(ied,i)=itedge(index(ked,2),k)
                        itedge(ked,k)=itedge(index(ied,2),i)
                        itedge(index(ied,2),i)=index(ked,2)+4*k
                        itedge(index(ked,2),k)=index(ied,2)+4*i
                        j=itedge(ied,i)/4
                        if(j>0) then
                            jed=itedge(ied,i)-4*j
                            itedge(jed,j)=ied+4*i
                        endif
                        j=itedge(ked,k)/4
                        if(j>0) then
                            jed=itedge(ked,k)-4*j
                            itedge(jed,j)=ked+4*k
                        endif
                    enddo
                enddo
                if(ichng<=0) exit
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine eswapc(i,itnode,itedge,ibndry,ibedge,vx,vy,
     +      iseed,vtype,itdof,ndf,ngf,maxd,gf,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(*) :: iseed,vtype
            integer(kind=iknd), dimension(3) :: iords,iv,istart,istop
            integer(kind=iknd), save, dimension(3) :: ibmptr
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(500) :: vlist,tlist,elist,
     +          blist
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), save, dimension(3) :: bump,e
            real(kind=rknd), dimension(maxd,*) :: gf
cy
            data index/1,2,3,2,3,1,3,1,2/
            data ibmptr/3*0/
            data bump/3*0.0e0_rknd/
            data e/3*0.0e0_rknd/
c
        iflag=0
        call cirlst(i,itnode,itedge,ibndry,ibedge,
     +      iseed,vtype,vlist,tlist,elist,blist,len)
c
c       make all elements and spoke edges for vertex i the
c       same order
c
        iiord=100
        num=1
        istart(1)=1
        istop(1)=len
        if(vtype(i)>=7) istart(1)=2
        if(vtype(i)>=9) then
            num=2
            istart(2)=len+3
            istop(2)=elist(len+2)
        endif
        do m=1,num
            do k=istart(m),istop(m)
                it=tlist(k)
                call locord(it,ndof,iord,iords,itdof)
                iiord=min(iord,iiord)
            enddo
        enddo
c
c       make interior elements order iiord
c
        do m=1,num
            do k=istart(m),istop(m)
                it=tlist(k)
                call locord(it,ndof,iord,iords,itdof)
                j=abs(elist(k))
                iords(index(2,j))=0
                iords(index(3,j))=0
                call p2qdof(it,iiord,iords,ndf,ngf,maxd,
     +              itedge,ibedge,ibndry,itdof,gf,incdf,iv,iflag)
            enddo
        enddo
c
c       reduce degree to 3 or 4 by swapping edges
c
        if(vtype(i)>=7) go to 30
        if(len<=4) return
c
        ivf1=0
        ivf2=0
        do j=2,len+1
            if(elist(j)<0) then
                if(ivf1==0) then
                    ivf1=vlist(j)
                else
                    ivf2=vlist(j)
                endif
            endif
        enddo
c
c
   10   if(len>4) then
            jj=2
            gs=-1.0e0_rknd
            do j=2,len+1
                if(vlist(j)==ivf1.or.vlist(j)==ivf2) cycle
                if(vlist(j-1)==ivf1.and.vlist(j+1)==ivf2) cycle
                if(vlist(j+1)==ivf1.and.vlist(j-1)==ivf2) cycle
                qq=geom(i,vlist(j-1),vlist(j+1),vx,vy)
                if(qq<=0.0e0_rknd) cycle
                gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy)
                if(gg<=gs) cycle
                jj=j
                gs=gg
            enddo
            if(gs<=0.0e0_rknd) then
                iflag=1
                return
            endif
            k=index(3,abs(elist(jj)))
            it=tlist(jj)
            call eleswp(it,k,itnode,itedge,ibedge,itdof,
     +          ngf,maxd,gf,1_iknd,ibmptr,bump,3_iknd,e,iseed,
     1          vx,vy,0_iknd,1_iknd,1_iknd)
            call cirlst(i,itnode,itedge,ibndry,ibedge,
     +          iseed,vtype,vlist,tlist,elist,blist,len)
            go to 10
        endif
        return
c
c       boundary cases
c
   30   if(len>3) then
            jj=3
            gs=-1.0e0_rknd
            do j=3,len
                qq=geom(i,vlist(j-1),vlist(j+1),vx,vy)
                if(qq<=0.0e0_rknd) cycle
                gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy)
                if(gg<=gs) cycle
                jj=j
                gs=gg
            enddo
            if(gs<=0.0e0_rknd) then
                iflag=2
                return
            endif
            k=index(3,abs(elist(jj)))
            it=tlist(jj)
            call eleswp(it,k,itnode,itedge,ibedge,itdof,
     +          ngf,maxd,gf,1_iknd,ibmptr,bump,3_iknd,e,iseed,
     1          vx,vy,0_iknd,1_iknd,1_iknd)
            call cirlst(i,itnode,itedge,ibndry,ibedge,
     +          iseed,vtype,vlist,tlist,elist,blist,len)
            go to 30
        endif
        if(vtype(i)/=9) return
   50   ks1=len+3
        len1=elist(len+2)
        ii=vlist(len+2)
        if(len1+2-ks1>3) then
            jj=ks1+1
            gs=-1.0e0_rknd
            do j=ks1+1,len1
                qq=geom(ii,vlist(j-1),vlist(j+1),vx,vy)
                if(qq<=0.0e0_rknd) cycle
                gg=geom(vlist(j-1),vlist(j),vlist(j+1),vx,vy)
                if(gg<=gs) cycle
                jj=j
                gs=gg
            enddo
            if(gs<=0.0e0_rknd) then
                iflag=3
                return
            endif
            k=index(3,abs(elist(jj)))
            it=tlist(jj)
            call eleswp(it,k,itnode,itedge,ibedge,itdof,
     +          ngf,maxd,gf,1_iknd,ibmptr,bump,3_iknd,e,iseed,
     1          vx,vy,0_iknd,1_iknd,1_iknd)
            call cirlst(i,itnode,itedge,ibndry,ibedge,
     +          iseed,vtype,vlist,tlist,elist,blist,len)
            go to 50
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mfe0(nv1,nv2,nt1,nt2,itnode,itedge,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(50) :: vlist
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(nv2) :: list
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       this routine tries to optimize knot placement
c
        if(nv1>nv2) return
        tol=1.0e-3_rknd
        s3=sqrt(3.0e0_rknd)/2.0e0_rknd
        itmax=4
c
c       make list of seed triangles
c
        do i=nt1,nt2
            do j=1,3
                list(itnode(j,i))=4*i+j
            enddo
        enddo
c
c       thr main loop in which the knots positions are
c       optimized
c
        do itnum=1,itmax
            do i=nv1,nv2
c
c       compute circular list of vertices
c
                ideg=0
                k=list(i)/4
                ke=list(i)-4*k
                ke=index(2,ke)
                kv=itnode(ke,k)
                kk=kv
   10           ideg=ideg+1
                if(ideg>30) stop 5521
                vlist(ideg)=kk
                j=itedge(ke,k)/4
                ke=itedge(ke,k)-4*j
                k=j
                ke=index(3,ke)
                if(itnode(index(3,ke),k)/=i) stop 6630
                kk=itnode(ke,k)
                if(kk/=kv) go to 10
                vlist(ideg+1)=kv
c
                qmin=1.0e0_rknd
                qmin2=1.0e0_rknd
                k1=0
                k2=0
                do k=1,ideg
                    kb=vlist(k)
                    ka=vlist(k+1)
                    q=geom(i,kb,ka,vx,vy)
                    if(q<qmin) then
                        qmin2=qmin
                        qmin=q
                        k2=k1
                        k1=k
                    else if(q<qmin2) then
                        qmin2=q
                        k2=k
                    endif
                enddo
                xmin=vx(i)
                ymin=vy(i)
                kb=vlist(k1)
                ka=vlist(k1+1)
                dxk=(vx(ka)-vx(kb))
                dyk=(vy(ka)-vy(kb))
                xmk=(vx(kb)+vx(ka))/2.0e0_rknd
                ymk=(vy(kb)+vy(ka))/2.0e0_rknd
c
                dxk=dxk*s3
                dyk=dyk*s3
                xmax=xmk-dyk
                ymax=ymk+dxk
                rk=sqrt(dxk*dxk+dyk*dyk)
                lb=vlist(k2)
                la=vlist(k2+1)
                dxl=(vx(la)-vx(lb))*s3
                dyl=(vy(la)-vy(lb))*s3
                xml=(vx(lb)+vx(la))/2.0e0_rknd
                yml=(vy(lb)+vy(la))/2.0e0_rknd
                rl=sqrt(dxl*dxl+dyl*dyl)
                xm=xmk-xml
                dx=dxk-dxl
                ym=ymk-yml
                dy=dyk-dyl
                r=rk+rl
                a=r*r-dx*dx-dy*dy
                b=ym*dx-xm*dy
                c=xm*xm+ym*ym+r*r
                beta=1.0e0_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
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)<tol) then
                    vx(i)=xmin
                    vy(i)=ymin
                else
                    vx(i)=(xmin+xmax)/2.0e0_rknd
                    vy(i)=(ymin+ymax)/2.0e0_rknd
                    qq=1.0e0_rknd
                    do k=1,ideg
                        kb=vlist(k)
                        ka=vlist(k+1)
                        q=geom(i,kb,ka,vx,vy)
                        if(q<qmin) then
                            xmax=vx(i)
                            ymax=vy(i)
                            go to 85
                        endif
                        qq=min(qq,q)
                    enddo
                    xmin=vx(i)
                    ymin=vy(i)
                    qmin=qq
                    go to 85
                endif
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine liarc(p,dp,q,t,r,npts,al,ang,eps)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(2) :: p,dp,q,t,al,ang
cy
c       compute the intersection,if any, between the line
c       given by p and dp and the arc with center q , radius r
c       and theta range t.
c
        pi=3.141592653589793e0_rknd
        rr=abs(r)
        x=(p(1)-q(1))/rr
        y=(p(2)-q(2))/rr
        dx=dp(1)/rr
        dy=dp(2)/rr
c
c       solve quadratic
c
        c=x*x+y*y-1.0e0_rknd
        b=-(x*dx+y*dy)
        a=dx*dx+dy*dy
        disc=b*b-a*c
c
        if(disc>0.0e0_rknd) then
            d=sqrt(disc)
            npts=2
            if(b>=0.0e0_rknd) then
                al(1)=(b+d)/a
                al(2)=c/(b+d)
            else
                al(1)=c/(b-d)
                al(2)=(b-d)/a
            endif
        else if(disc==0.0e0_rknd) then
            npts=1
            al(1)=b/a
        else
            npts=0
            return
        endif
c
c       compute theta values
c
        tmin=min(t(1),t(2))
        tmax=max(t(1),t(2))
        tol=eps*(tmax-tmin)
        do i=1,npts
            x=(p(1)-q(1)+al(i)*dp(1))/rr
            y=(p(2)-q(2)+al(i)*dp(2))/rr
            x=min(1.0e0_rknd,x)
            x=max(-1.0e0_rknd,x)
            th=acos(x)/pi
            if(y<0.0e0_rknd) th=-th
            do j=1,5
                theta=th+real(j-3,rknd)*2.0e0_rknd
                if(abs(theta-tmin)<=tol) theta=tmin
                if(theta>=tmin) exit
            enddo
            if(abs(theta-tmax)<=tol) theta=tmax
            ang(i)=theta
        enddo
        if(npts==2.and.ang(2)<ang(1)) then
            a=ang(1)
            ang(1)=ang(2)
            ang(2)=a
            a=al(1)
            al(1)=al(2)
            al(2)=a
        endif
        if(ang(1)>tmax) npts=0
        if(npts==2.and.ang(2)>tmax) npts=1
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine lil(p,dp,q,dq,al,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(2) :: p,dp,q,dq,al
cy
c       this routine find the intersection of two lines
c       if the lines are parallel iflag is set to 1
c
        d1=p(1)-q(1)
        d2=p(2)-q(2)
        det=dp(2)*dq(1)-dp(1)*dq(2)
        if(det/=0.0e0_rknd) then
            al(1)=(d1*dq(2)-d2*dq(1))/det
            al(2)=(dp(2)*d1-dp(1)*d2)/det
            iflag=0
        else
            al(1)=0.0e0_rknd
            al(2)=0.0e0_rknd
            iflag=1
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function chloc(kb,kv,ka,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd) :: chloc
cy
c       this routine computes the local value of h
c
        x1=vx(ka)-vx(kv)
        y1=vy(ka)-vy(kv)
        x2=vx(kb)-vx(kv)
        y2=vy(kb)-vy(kv)
        chloc=((x1*x1+y1*y1)*(x2*x2+y2*y2))**0.25e0_rknd
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function geom(kv,kb,ka,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd) :: geom
cy
c       this function  computes a constant between
c       zero and one indicative of the quality of a triangle
c       (geom is neg if verts are given in clockwise order)
c
        x1=vx(ka)-vx(kv)
        y1=vy(ka)-vy(kv)
        x2=vx(kb)-vx(kv)
        y2=vy(kb)-vy(kv)
        det=x2*y1-x1*y2
        dd=x1*x1+y1*y1+x2*x2+y2*y2+(x1-x2)*(x1-x2)+
     +      (y1-y2)*(y1-y2)
        geom=det*3.464101616e0_rknd/dd
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function ch(kv,kb,ka,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd) :: ch
cy
c       diameter of circumscribing circle
c
        x1=vx(ka)-vx(kv)
        y1=vy(ka)-vy(kv)
        x2=vx(kb)-vx(kv)
        y2=vy(kb)-vy(kv)
        d0=sqrt(abs(x2*y1-x1*y2))
        d1=sqrt(x1**2+y1**2)/d0
        d2=sqrt(x2**2+y2**2)/d0
        d3=sqrt((x1-x2)**2+(y1-y2)**2)/d0
        ch=d0*d1*d2*d3
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function cangmx(kb,kv,ka,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(3) :: h
            real(kind=rknd) :: cangmx
            real(kind=rknd), save :: pi=3.141592653589793e0_rknd
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       the function computes largest angle of the
c       triangle defined by the vertices kb,kv,ka
c
        h(1)=(vx(ka)-vx(kb))**2+(vy(ka)-vy(kb))**2
        h(2)=(vx(kb)-vx(kv))**2+(vy(kb)-vy(kv))**2
        h(3)=(vx(kv)-vx(ka))**2+(vy(kv)-vy(ka))**2
        j=1
        if(h(2)>h(1)) j=2
        if(h(3)>h(j)) j=3
        j2=index(2,j)
        j3=index(3,j)
        h(j2)=h(j2)/h(j)
        h(j3)=h(j3)/h(j)
        q=(h(j2)+h(j3)-1.0e0_rknd)/(2.0e0_rknd*sqrt(h(j2)*h(j3)))
        q=min(1.0e0_rknd,q)
        q=max(-1.0e0_rknd,q)
        cangmx=acos(q)/pi
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function cangmn(kb,kv,ka,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(3) :: h
            real(kind=rknd) :: cangmn
            real(kind=rknd), save :: pi=3.141592653589793e0_rknd
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       the function computes smallest angle of the
c       triangle defined by the vertices kb,kv,ka
c
        h(1)=(vx(ka)-vx(kb))**2+(vy(ka)-vy(kb))**2
        h(2)=(vx(kb)-vx(kv))**2+(vy(kb)-vy(kv))**2
        h(3)=(vx(kv)-vx(ka))**2+(vy(kv)-vy(ka))**2
        j=1
        if(h(2)<h(1)) j=2
        if(h(3)<h(j)) j=3
        j2=index(2,j)
        j3=index(3,j)
        h(j2)=h(j2)/h(j)
        h(j3)=h(j3)/h(j)
        q=(h(j2)+h(j3)-1.0e0_rknd)/(2.0e0_rknd*sqrt(h(j2)*h(j3)))
        q=min(1.0e0_rknd,q)
        q=max(-1.0e0_rknd,q)
        cangmn=acos(q)/pi
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function cang(kb,kv,ka,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd) :: cang
            real(kind=rknd), save :: pi=3.141592653589793e0_rknd
cy
c       the function computes the interior angle
c       given by the segments (kb,kv) and (kv,ka)
c
        x1=vx(ka)-vx(kv)
        x2=vx(kb)-vx(kv)
        y1=vy(ka)-vy(kv)
        y2=vy(kb)-vy(kv)
        xx=x2*x1+y2*y1
        yy=x1*y2-y1*x2
        s=xx/sqrt(xx**2+yy**2)
        s=min(1.0e0_rknd,s)
        s=max(-1.0e0_rknd,s)
        cang=acos(s)/pi
        if(yy<=0.0e0_rknd) cang=2.0e0_rknd-cang
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dvpram(hl,hr,d,rp,al,h,np)
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       this routine determines the number of points and the
c       spacing parameters for dividing up a line segment
c
        epsm=1.0e0_rknd-1.0e1_rknd*epsilon(1.0e0_rknd)
        grade=rp(13)
        np=0
        al=1.0e0_rknd
        h=1.0e0_rknd
        hmax=max(hl,hr)/d
        if(hmax>=epsm) return
        hmin=min(hl,hr)/d
        if(hmin*grade>=epsm) return
c
c       find np by increasing hmin as quickly as possible
c
        q=hmin
    3   np=np+1
        hmin=min(hmin*grade,hmax)
        q=q+hmin
        if(q<epsm) go to 3
        if(q>1.0e0_rknd+hmax/2.0e0_rknd) np=np-1
c
c       hr=hl*al**(np+1) and h*(1-al**(np+1))/(1-al)=1
c       are the two equations that determine al and h
c
        if(np==0) return
        r=hr/hl
        if(abs(r-1.0e0_rknd)<1.0e-3_rknd) then
            h=1.0e0_rknd/real(np+1,rknd)
        else
            al=r**(1.0e0_rknd/real(np+1,rknd))
            al=min(grade,al)
            al=max(1.0e0_rknd/grade,al)
            h=(al-1.0e0_rknd)/(al**(np+1)-1.0e0_rknd)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine lngedg(ntr,nvr,nbr,maxv,maxb,rp,vx,vy,sf,
     +      itnode,ibndry,iflag,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(3*nbr) :: jb
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(maxv) :: iequv
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(maxv) :: hloc
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(17) :: x,y,fi
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
c
c       look for long edges connected to only short edges and  divide
c
        hmax=rp(78)*rp(12)
        grade=rp(13)
        pi=3.141592653589793e0_rknd
        factor=1.1e0_rknd
        num=16
c
c       make jb
c
        call makjb(nvr,nbr,ntr,vx,vy,sf,ibndry,itnode,1_iknd,jb,
     +      iflag,nrl,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,nrl,rl,sxy)
            if(hloc(iequv(j1))<=0.0e0_rknd) then
                hloc(iequv(j1))=d
            else
                hloc(iequv(j1))=min(d,hloc(iequv(j1)))
            endif
            if(hloc(iequv(j2))<=0.0e0_rknd) then
                hloc(iequv(j2))=d
            else
                hloc(iequv(j2))=min(d,hloc(iequv(j2)))
            endif
        enddo
        do i=1,nvr
            hloc(i)=hloc(iequv(i))
        enddo
c
c       now look for long edges on the basis of hloc
c
        nbr0=nbr
        do i=1,nbr0
            iequv(i)=0
            j1=ibndry(1,i)
            j2=ibndry(2,i)
            jc=ibndry(3,i)
c
c       see if h can be increased near center of interval
c
            call arclen(i,ibndry,1_iknd,sf,vx,vy,d,theta1,
     +          theta2,radius,num,x,y,fi,nrl,rl,sxy)
c
            if(d<=grade*(hloc(j1)+hloc(j2))) cycle
            ds=d*(grade-1.0e0_rknd)/grade
            theta=(hloc(j1)-hloc(j2))/(2.0e0_rknd*ds)
            if(abs(theta)>0.4e0_rknd) cycle
            f1=0.5e0_rknd-theta
            f2=0.5e0_rknd+theta
            hmm=(ds+hloc(j1)+hloc(j2))/2.0e0_rknd
            hmin=f1*hloc(j2)+f2*hloc(j1)
            hmm=min(hmm,hmax)
            if(hmm<hmin*factor) cycle
c
c       add new point, edge
c
            if(nvr>=maxv) then
                iflag=84
                return
            endif
            nvr=nvr+1
            if(jc>0) then
                theta=(f1*theta2+f2*theta1)*pi
                vx(nvr)=sf(1,i)+radius*cos(theta)
                vy(nvr)=sf(2,i)+radius*sin(theta)
            else if(jc<0) then
                do m=1,num
                    k=m
                    if(fi(m+1)>f1) exit
                enddo
                k=max(2,k)
                if(abs(fi(k)-f1)>abs(fi(k+1)-f1)) k=k+1
                k=min(num,k)
                vx(nvr)=x(k)
                vy(nvr)=y(k)
                dt=(theta2-theta1)/real(num,rknd)
                thetam=theta1+dt*real(k-1,rknd)
            else
                vx(nvr)=f1*vx(j2)+f2*vx(j1)
                vy(nvr)=f1*vy(j2)+f2*vy(j1)
            endif
            if(nbr>=maxb) then
                iflag=86
                return
            endif
            nbr=nbr+1
            iequv(i)=nbr
            do j=1,7
                ibndry(j,nbr)=ibndry(j,i)
            enddo
            do j=1,2
                sf(j,nbr)=sf(j,i)
            enddo
            if(jc<0) then
                sf(1,nbr)=thetam
                sf(2,i)=thetam
            endif
            ibndry(2,i)=nvr
            ibndry(1,nbr)=nvr
        enddo
        if(nbr0<nbr) then
            do i=nbr0+1,nbr
                if(ibndry(4,i)>=0) cycle
                k=-ibndry(4,i)
                ibndry(4,k)=-i
            enddo
        endif
c
c       fix itnode
c
        do i=1,ntr
           k=itnode(1,i)
           j=itnode(2,i)
           if(ibndry(1,j)==k.or.ibndry(2,j)==k) cycle
           jj=iequv(j)
           if(ibndry(2,jj)/=k) stop 9328
           itnode(2,i)=jj
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine arclen(iedge,ibndry,isw,sf,vx,vy,
     +      alen,theta1,theta2,radius,num,x,y,fi,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(7,*) :: ibndry
            real(kind=rknd), dimension(*) :: vx,vy,fi,x,y
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(2,15) :: values
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
c
c       compute approximate arclength
c
        if(isw==1) then
            k1=1
            k2=2
        else
            k1=2
            k2=1
        endif
        j1=ibndry(k1,iedge)
        j2=ibndry(k2,iedge)
        jc=ibndry(3,iedge)
        if(jc>0) then
            call arc(vx(j1),vy(j1),vx(j2),vy(j2),
     +          sf(1,iedge),sf(2,iedge),
     1          theta1,theta2,radius,alen)
        else if(jc<0) then
            itag=-jc
            theta1=sf(k1,iedge)
            theta2=sf(k2,iedge)
            x(1)=vx(j1)
            y(1)=vy(j1)
            dt=(theta2-theta1)/real(num,rknd)
            alen=0.0e0_rknd
            fi(1)=0.0e0
            do k=2,num+1
                do m=1,2+nrl
                    values(1,m)=0.0e0_rknd
                    values(2,m)=0.0e0_rknd
                enddo
                theta=theta1+dt*real(k-1,rknd)
                call sxy(rl,theta,itag,values)
                x(k)=values(1,1)
                y(k)=values(2,1)
                fi(k)=sqrt((x(k)-x(k-1))**2+(y(k)-y(k-1))**2)
                alen=alen+fi(k)
                fi(k)=alen
            enddo
            do k=1,num+1
                fi(k)=fi(k)/alen
            enddo
        else
            alen=sqrt((vx(j1)-vx(j2))*(vx(j1)-vx(j2))+
     +          (vy(j1)-vy(j2))*(vy(j1)-vy(j2)))
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine makjb(nvf,nbf,ntf,vx,vy,sf,ibndry,itnode,jbsw,
     +      jb,iflag,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(nvf+2*nbf+1) :: list
            integer(kind=iknd), dimension(nvf) :: ibdy
            integer(kind=iknd), dimension(nbf) :: orient,num
            integer(kind=iknd), dimension(*) :: jb
            integer(kind=iknd), dimension(5,*) :: itnode
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
c
c       compute jb from skeleton data arrays ibndry,vx,vy,xm,ym
c
        iflag=0
        ntf=0
c
c       initialize with list of edges as function of vertex in list
c
        do i=1,nvf
            ibdy(i)=0
            list(i+1)=0
        enddo
        do i=1,nbf
           list(ibndry(1,i)+1)=list(ibndry(1,i)+1)+1
           list(ibndry(2,i)+1)=list(ibndry(2,i)+1)+1
            if(ibndry(4,i)==0) then
                num(i)=2
            else
                num(i)=1
                ibdy(ibndry(1,i))=ibdy(ibndry(1,i))-1
                ibdy(ibndry(2,i))=ibdy(ibndry(2,i))-1
            endif
        enddo
        list(1)=nvf+2
        do i=1,nvf
            list(i+1)=list(i)+list(i+1)
            if(ibdy(i)==0) cycle
            if(ibdy(i)/=-2) then
                iflag=-48
                return
            endif
        enddo
c
c       order boundary edges first
c
        do i=1,nbf
            if(ibndry(4,i)==0) cycle
            do k=1,2
                j=ibndry(k,i)
                list(list(j))=i
                list(j)=list(j)+1
            enddo
        enddo
        do i=1,nbf
            if(ibndry(4,i)/=0) cycle
            do k=1,2
                j=ibndry(k,i)
                list(list(j))=i
                list(j)=list(j)+1
            enddo
        enddo
        do i=nvf,2,-1
            list(i)=list(i-1)
        enddo
        list(1)=nvf+2
c
c       now we order the boundary edges as after/before
c       find lower left vertex from among the remaining vertices
c       (we need this in case there are disconnected regions)
c
        nseg=0
   10   left=0
        do i=1,nvf
            if(ibdy(i)>=0) cycle
            if(left==0) then
                left=i
            else if(vx(i)<vx(left)) then
                left=i
            else if(vx(i)==vx(left).and.vy(i)<vy(left)) then
                left=i
            endif
        enddo
        if(left==0) go to 30
        nseg=nseg+1
        ii=list(left)
        ibef=list(ii+1)
        iaft=list(ii)
        ivb=ibndry(1,ibef)+ibndry(2,ibef)-left
        iva=ibndry(1,iaft)+ibndry(2,iaft)-left
        qq=geom(ivb,left,iva,vx,vy)
        if(qq<0.0e0_rknd) then
             itemp=list(ii)
             list(ii)=list(ii+1)
             list(ii+1)=itemp
        endif
        iv=left
   20   ibdy(iv)=nseg
        ii=list(iv)
        iaft=list(ii)
        jv=ibndry(1,iaft)+ibndry(2,iaft)-iv
        jj=list(jv)
        if(list(jj)==iaft) then
             list(jj)=list(jj+1)
             list(jj+1)=iaft
        endif
        if(ibndry(4,list(jj))==0) stop 5567
        iv=jv
        if(iv/=left) go to 20
        go to 10
c
c       compute jb based on lower left vertex
c       this loop is needed to compute orient correctly
c
   30   do i=1,nseg
            orient(i)=0
        enddo
        jb(1)=nbf+2
c
c       find lower left vertex
c
   40   left=0
        do i=1,nbf
            if(num(i)<=0) cycle
            if(left==0) left=ibndry(1,i)
            do k=1,2
                j=ibndry(k,i)
                if(vx(j)<vx(left)) then
                    left=j
                else if(vx(j)==vx(left).and.
     +              vy(j)<vy(left)) then
                    left=j
                endif
            enddo
        enddo
c
c       find starting edge
c
        if(left==0) go to 70
        i1=list(left)
        i2=list(left+1)-1
        icur=0
        jcur=0
        do ii=i1,i2
            i=list(ii)
            if(num(i)/=1) cycle
            if(icur==0) then
                icur=i
            else
                jcur=i
                iv1=ibndry(1,icur)+ibndry(2,icur)-left
                iv2=ibndry(1,jcur)+ibndry(2,jcur)-left
                qq=geom(left,iv1,iv2,vx,vy)
                if(qq<0.0e0_rknd) then
                    jcur=icur
                    icur=i
                endif
            endif
        enddo
        if(jcur==0) then
            iflag=-43
            return
        endif
c
c       orient(i) = 1 if counterclockwise
c       orient(i) = -1 if clockwise (this happens for holes in cnext)
c
        if(ibndry(4,icur)/=0) then
            iseg=ibdy(left)
            orient(iseg)=1
        endif
c
        ntf=ntf+1
        ii=jb(ntf)
        istart=icur
        iv=left
   50   if(num(icur)<=0) then
            iflag=-53
            return
        endif
        num(icur)=num(icur)-1
        jb(ii)=icur
        call cnext(iv,icur,list,ibndry,ibdy,orient,vx,vy,sf,next,
     +      nrl,rl,sxy)
        if(next==istart) then
            jb(ntf+1)=ii+1
            go to 40
        else
            iv=ibndry(1,icur)+ibndry(2,icur)-iv
            icur=next
            ii=ii+1
            go to 50
        endif
c
c
c
   70   ishift=ntf-nbf
        do i=jb(1),jb(ntf+1)-1
             jb(i+ishift)=jb(i)
        enddo
        do i=1,ntf+1
            jb(i)=jb(i)+ishift
        enddo
        if(jbsw==1) go to 80
c
c       make an itnode array from the given jb array
c
        do i=1,ntf
            i1=jb(i)
            i2=jb(i+1)-1
            ie1=jb(i1)
            ie2=jb(i2)
            iv=ibndry(1,ie1)
            jv=ibndry(2,ie1)
            if(iv/=ibndry(1,ie2).and.iv/=ibndry(2,ie2)) iv=jv
            itnode(1,i)=iv
            itnode(2,i)=ie1
            itnode(3,i)=0
            itnode(4,i)=1
            itnode(5,i)=i
        enddo
        return
c
c       make jb for the specified itnode array
c
   80   jb(1)=ntf+2
        do i=1,nbf
            if(ibndry(4,i)==0) then
                num(i)=2
            else
                num(i)=1
            endif
        enddo
        do i=1,ntf
            ii=jb(i)
            iv=itnode(1,i)
            icur=itnode(2,i)
            istart=icur
   90       if(num(icur)<=0) then
                iflag=-53
                return
            endif
            num(icur)=num(icur)-1
            jb(ii)=icur
            call cnext(iv,icur,list,ibndry,ibdy,orient,vx,vy,sf,next,
     +          nrl,rl,sxy)
            if(next==istart) then
                jb(i+1)=ii+1
            else
                iv=ibndry(1,icur)+ibndry(2,icur)-iv
                icur=next
                ii=ii+1
                go to 90
            endif
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cnext(iv,icur,list,ibndry,ibdy,orient,vx,vy,sf,next,
     +      nrl,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(*) :: list,ibdy,orient
            integer(kind=iknd), save :: i1=1,i2=2,i3=3
            real(kind=rknd), dimension(3) :: x,y
            real(kind=rknd), dimension(2,15) :: values
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
c
        pi=3.141592653589793e0_rknd
        eps=1.0e-4_rknd
        jv=ibndry(1,icur)+ibndry(2,icur)-iv
        j1=list(jv)
        j2=list(jv+1)-1
c
c       simple case
c
        if(j2==j1+1) then
            next=list(j1)
            if(next==icur) next=list(j2)
            return
        endif
c
c       general case
c
        next=0
        ang=3.0e0_rknd
        do kk=j2,j1,-1
            k=list(kk)
            if(k==icur) cycle
            kv=ibndry(1,k)+ibndry(2,k)-jv
c
c       check curved edges
c
            if(ibndry(3,icur)>0) then
                call arc(vx(iv),vy(iv),vx(jv),vy(jv),
     +              sf(1,icur),sf(2,icur),thetab,thetac,rad,hh)
                arg=(0.95e0_rknd*thetac+0.05e0_rknd*thetab)*pi
                x(1)=sf(1,icur)+rad*cos(arg)
                y(1)=sf(2,icur)+rad*sin(arg)
            else if(ibndry(3,icur)<0) then
                itag=-ibndry(3,icur)
                if(iv==ibndry(1,icur)) then
                    thetab=sf(1,icur)
                    thetac=sf(2,icur)
                else
                    thetac=sf(1,icur)
                    thetab=sf(2,icur)
                endif
                theta=0.95e0_rknd*thetac+0.05e0_rknd*thetab
                do mm=1,2+nrl
                    values(1,mm)=0.0e0_rknd
                    values(2,mm)=0.0e0_rknd
                enddo
                call sxy(rl,theta,itag,values)
                x(1)=values(1,1)
                y(1)=values(2,1)
            else
                x(1)=vx(iv)
                y(1)=vy(iv)
            endif
            x(2)=vx(jv)
            y(2)=vy(jv)
            if(ibndry(3,k)>0) then
                call arc(vx(kv),vy(kv),vx(jv),vy(jv),
     +              sf(1,k),sf(2,k),thetaa,thetac,rad,hh)
                arg=(0.95e0_rknd*thetac+0.05e0_rknd*thetaa)*pi
                x(3)=sf(1,k)+rad*cos(arg)
                y(3)=sf(2,k)+rad*sin(arg)
            else if(ibndry(3,k)<0) then
                itag=-ibndry(3,k)
                if(kv==ibndry(1,k)) then
                    thetaa=sf(1,k)
                    thetac=sf(2,k)
                else
                    thetac=sf(1,k)
                    thetaa=sf(2,k)
                endif
                theta=0.95e0_rknd*thetac+0.05e0_rknd*thetaa
                do mm=1,2+nrl
                    values(1,mm)=0.0e0_rknd
                    values(2,mm)=0.0e0_rknd
                enddo
                call sxy(rl,theta,itag,values)
                x(3)=values(1,1)
                y(3)=values(2,1)
            else
                x(3)=vx(kv)
                y(3)=vy(kv)
            endif
            aa=cang(i1,i2,i3,x,y)
c
c       this section handles roundoff error problems at cracks
c
            if(ibndry(4,k)/=0) then
                iseg=ibdy(kv)
                if(orient(iseg)==0) orient(iseg)=-1
                if(ibndry(4,icur)/=0) then
                    if(aa<eps) aa=2.0e0_rknd-eps
                else
                    a0=abs(aa-ang)
                    if(a0<eps.and.kk==j1) then
                        if(orient(iseg)==1) then
                            if(next==list(j1+1)) then
                                aa=ang-eps
                            endif
                        else
                            if(next==list(j1+1)) then
                                aa=ang+eps
                            endif
                        endif
                    endif
                endif
            endif
c
            if(aa>=ang) cycle
            ang=aa
            next=k
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine xybox(nbf,vx,vy,sf,ibndry,vmin,vmax,diam,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(7,*) :: ibndry
            real(kind=rknd), dimension(2) :: vmin,vmax
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(2,15) :: values
cy
            external sxy
c
c       find a box containing domain
c
        num=16
        xmin=vx(ibndry(1,1))
        ymin=vy(ibndry(1,1))
        xmax=xmin
        ymax=ymin
        do i=1,nbf
            xmin=min(xmin,vx(ibndry(1,i)),vx(ibndry(2,i)))
            ymin=min(ymin,vy(ibndry(1,i)),vy(ibndry(2,i)))
            xmax=max(xmax,vx(ibndry(1,i)),vx(ibndry(2,i)))
            ymax=max(ymax,vy(ibndry(1,i)),vy(ibndry(2,i)))
c
c       check for curved edges
c
            if(ibndry(3,i)==0) cycle
            if(ibndry(3,i)>0) then
                xc=sf(1,i)
                yc=sf(2,i)
                x1=vx(ibndry(1,i))-xc
                y1=vy(ibndry(1,i))-yc
                x2=vx(ibndry(2,i))-xc
                y2=vy(ibndry(2,i))-yc
                rad=sqrt(x1**2+y1**2)
                if(x1*x2<0.0e0_rknd) then
                    al=x1/(x1-x2)
                    if(y1+al*(y2-y1)>0.0e0_rknd) then
                        ymax=max(ymax,yc+rad)
                    else
                        ymin=min(ymin,yc-rad)
                    endif
                endif
                if(y1*y2<0.0e0_rknd) then
                    al=y1/(y1-y2)
                    if(x1+al*(x2-x1)>0.0e0_rknd) then
                        xmax=max(xmax,xc+rad)
                    else
                        xmin=min(xmin,xc-rad)
                    endif
                endif
            else
                itag=-ibndry(3,i)
                theta1=sf(1,i)
                theta2=sf(2,i)
                dt=(theta2-theta1)/real(num,rknd)
                do k=1,num-1
                    do m=1,2+nrl
                        values(1,m)=0.0e0_rknd
                        values(2,m)=0.0e0_rknd
                    enddo
                    theta=theta1+dt*real(k,rknd)
                    call sxy(rl,theta,itag,values)
                    x=values(1,1)
                    y=values(2,1)
                    xmin=min(x,xmin)
                    xmax=max(x,xmax)
                    ymin=min(y,ymin)
                    ymax=max(y,ymax)
                enddo
            endif
        enddo
c
c       compute diameter
c
        diam=sqrt((xmax-xmin)**2+(ymax-ymin)**2)
        vmin(1)=xmin
        vmin(2)=ymin
        vmax(1)=xmax
        vmax(2)=ymax
        return
        end
c***************************** file: mg3.f *****************************
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine triplt(vx,vy,sf,itnode,ibndry,itdof,e,
     +      ip,rp,sp,gf,qxy,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(22) :: kdist
            integer(kind=iknd), dimension(3) :: ia
            integer(kind=iknd), allocatable, dimension(:,:) ::
     +          jtnode,jbndry,jtdof,itedge,ibedge,iuvptr
            integer(kind=iknd), allocatable, dimension(:) :: jord
            real(kind=rknd), allocatable, dimension(:) :: vx0,vy0,ut,vt
            real(kind=rknd), allocatable, dimension(:,:) :: sf0
            real(kind=rknd), dimension(*) :: vx,vy,e,gf
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(25) :: t,tl
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(4096) :: red,green,blue
            character(len=80), dimension(100) :: sp
cy
            external qxy,sxy
c
c       i        jp(i)                t(i)               tl(i)
c
c       1          ntf              xshift              xshift
c       2          nvf              yshift              yshift
c       3          nbf               scale               scale
c       4        icplt              zratio              zratio
c       5       ncolor              zshift              zshift
c       6       ierrsw
c       7   iprob/ispd                 eps                 eps
c       8  nrgn/iordsw                  xl           xl from t
c       9       inplsw                  xr           xr from t
c      10        igrsw                  yb           yb from t
c      11                               yt           yt from t
c      12        mpisw                rmag               1.0e0_rknd
c      13           nx
c      14           ny                size                size
c      15           nz                xcen                xcen
c      16       nshade                ycen                ycen
c      17       mxcolr                zcen                zcen
c      18       maplen
c      19       iscale                zmin                zmin
c      20        lines                zmax                zmax
c      21       numbrs                good                good
c      22          i3d                fair                fair
c      23        nproc                poor                poor
c      24          ndf               worst               worst
c      25                          average             average
c
c
c       storage allocation
c
        call setcom(ip)
c
c       error flags
c
        ip(25)=0
        if(itnode(3,1)==0) then
            iflag=25
            go to 20
        endif
c
        if(ip(5)/=0) then
            call stor(ip,rp)
            call dschek(vx,vy,sf,itnode,ibndry,ip,rp,sp,sxy)
            if(ip(25)/=0) return
c
c       setup itdof
c
            ntf=ip(1)
            nvf=ip(2)
            nbf=ip(3)
c
            call mkdof(ntf,nvf,nbf,ip,itnode,ibndry,itdof)
            maxt=ip(83)
            maxd=ip(85)
            call gfinit(ip,maxd,gf,maxt,e)
        endif
c
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        iprob=abs(ip(6))
        mxcolr=max(2,ip(51))
        mxcolr=min(4096,mxcolr)
        icrsn=ip(68)
        itrgt=ip(69)
        mpisw=ip(48)
        nproc=ip(49)
        irgn=ip(50)
        if(mpisw==1) then
            mpirgn=ip(47)
            if(mpirgn/=0) then
                if(mpirgn/=irgn) return
                mpisw=-1
            endif
            if(itnode(4,1)==0) mpisw=0
        endif
        do i=1,ntf
            nproc=max(nproc,itnode(4,i))
        enddo
c
        ndf=ip(4)
        ngf=ip(77)
        maxt=ip(83)
        maxd=ip(85)
c
c       initialize data structures
c
        if(mpisw==1) then
            call exflag(ip(24))
            if(ip(24)/=0) then
                iflag=24
                go to 20
            endif
            if(icrsn==1) then
                ia(1)=max(4*itrgt,ntf)
                ia(2)=max(2*itrgt,nbf)
                ia(3)=max(2*itrgt,nvf)
            else
                ia(1)=ntf*nproc
                ia(2)=nbf*nproc
                ia(3)=nvf*nproc
            endif
            call exsze(ia,0_iknd)
            lent=ia(1)
            lenb=ia(2)
            lenv=ia(3)
        else
            lent=ntf
            lenb=nbf
            lenv=nvf
        endif
c
        call clenut(ntf,itdof,lenut)
        lenut=int(real(lenut,rknd)*(real(lent,rknd)/real(ntf,rknd)))
c
        allocate(jtnode(5,lent),jbndry(7,lenb),jtdof(8,lent),
     +      iuvptr(2,lent+1),itedge(3,lent),ibedge(2,lenb),
     1      vx0(lenv),vy0(lenv),ut(lenut),vt(lenut),jord(lent),
     2      sf0(2,lenb))
c
        call cpds(ntf,nvf,nbf,itnode,ibndry,itdof,vx,vy,sf,
     +      jtnode,jbndry,jtdof,vx0,vy0,sf0)
c
c       compute function to be displayed
c
        ifun=ip(52)
c**     if(ifun<0.or.ifun>12) ifun=0
        nrl=ip(13)
        iprob=abs(ip(6))
        if(iprob==4) then
            do i=1,nrl
                rl(i)=rp(90+i)
            enddo
        else if(iprob==6) then
            rl(1)=rp(46)
        else
            rl(1)=rp(21)
        endif
c
        call gfptr(ip,iuu,iu0,iudot,iu0dot,
     +          ievr,ievl,ivx0,ivy0,ium,iuc,iudl)
        ivu=iuu
        iv1=iuu
        iv2=iuu
        ierrsw=0
        icont=0
        itype=0
        iee=1
        if(ifun==1) then
            itype=1
            if(ip(57)==1) icont=1
        else if(ifun==2) then
            itype=2
            if(ip(57)==1) icont=1
        else if(ifun==3) then
            itype=3
            if(ip(57)==1) icont=1
        else if(ifun==4) then
            itype=4
            if(ip(57)==1) icont=1
        else if(ifun==5) then
            itype=5
            if(ip(57)==1) icont=1
            if(icont==0.and.mpisw/=1.and.icrsn/=1) ierrsw=1
        else if(ifun==6) then
            ivu=iudot
        else if(ifun==7) then
            ivu=ievr
        else if(ifun==8) then
            ivu=ievl
        else if(ifun==9) then
            ivu=ium
        else if(ifun==10) then
            ivu=iuc
        else if(ifun==11) then
            ivu=iudl
        else if(ifun==12) then
            iee=iee+maxt
            itype=5
            if(ip(57)==1) icont=1
            if(icont==0.and.mpisw/=1.and.icrsn/=1) ierrsw=1
        else if(ifun<0) then
            ivu=-(1+ifun)*maxd+1
        endif
c
        call setfun(ntf,nvf,nbf,ndf,maxd,ngf,itype,icont,icplt,
     +      gf(ivu),gf(iv1),gf(iv2),e(iee),vx,vy,sf,iuvptr,ut,
     1      vt,jtnode,jbndry,nrl,rl,jtdof,qxy,sxy)
        call plinit(ip,rp,jtnode,jbndry,jtdof,itedge,ibedge,vx0,vy0,
     +      iuvptr,ut,vt,sf0,icplt,ierrsw,e(iee),kdist,q,t,tl,
     1      jp,ndf,nrl,rl,sxy)
c
c
        if(mpisw==1) then
            ia(1)=jp(1)
            ia(2)=jp(2)
            ia(3)=jp(3)
            call exsze(ia,1_iknd)
            ntf=ia(1)
            nvf=ia(2)
            nbf=ia(3)
            iflag=0
            if(ntf>lent) iflag=83
            if(nvf>lenv) iflag=84
            if(nbf>lenb) iflag=86
            if(iflag/=0) go to 10
            call glbpix(vx0,vy0,sf0,jbndry,jtnode,ia,iuvptr,
     +          ut,vt,jp,1_iknd)
            if(irgn==1) then
                call cedge1(nvf,ntf,nbf,jtnode,jbndry,itedge,
     +              ibedge,iflag)
            else
                iflag=0
                go to 10
            endif
        endif
c
c       ordering
c
        ilen=max(ntf,nbf)
        call torder(jp,jtnode,itedge,jord,ilen,vx0,vy0,q)
c
c       colormap
c
        call clrmap(red,green,blue,jp)
        call pltutl(jp(18),red,green,blue)
c
c       main plot
c
        call pframe(4_iknd)
        call title0(sp(1),0_iknd)
        call pframe(-4_iknd)
        call pframe(5_iknd)
        if(icplt==1) then
            call cplot(jp,jtnode,jbndry,itedge,jord,
     +          vx0,vy0,iuvptr,ut,sf0,q,t,nrl,rl,sxy)
        else
            call vplot(jp,jtnode,jbndry,itedge,jord,
     +          vx0,vy0,iuvptr,ut,vt,sf0,q,t,nrl,rl,sxy)
        endif
c
c       numbers
c
        if(jp(21)==1.or.jp(21)==10) then
            call tlabel(jp,jtnode,itdof,vx0,vy0,q,t)
        endif
        if(jp(21)==2.or.jp(21)==8) then
            llen=jp(2)
            call vlabel(llen,jp,jtnode,itedge,jbndry,
     +          ibedge,vx0,vy0,sf0,q,t)
        endif
        if(jp(21)==9) then
           ndf=ip(4)
           call dlabel(ndf,jp,jtnode,itdof,vx0,
     +      vy0,q,t)
        endif
        if(jp(21)>=3.and.jp(21)<=6) then
            call blabel(jp,jtnode,jbndry,
     +         ibedge,vx0,vy0,sf0,q,t,nrl,rl,sxy)
        endif
        if(jp(21)==7) then
            call plabel(nproc,jp,jtnode,vx0,vy0,q,t)
        endif
        call pframe(-5_iknd)
c
c       legend
c
        call pframe(2_iknd)
        if(icplt==1) then
            call legnd4(jp,tl,kdist)
        else
            call legnd3(jp,tl)
        endif
        call pframe(-2_iknd)
c
c       small plot
c
        call pframe(3_iknd)
        jp(20)=1
        if(t(12)<=1.0e0_rknd) jp(22)=0
        if(icplt==1) then
            jp(16)=0
            call cplot(jp,jtnode,jbndry,itedge,jord,
     +          vx0,vy0,iuvptr,ut,sf0,q,tl,nrl,rl,sxy)
        else
            call vplot(jp,jtnode,jbndry,itedge,jord,
     +          vx0,vy0,iuvptr,ut,vt,sf0,q,tl,nrl,rl,sxy)
        endif
        call legnd0(t)
        call pframe(-3_iknd)
c
        call pltutl(-1_iknd,red,green,blue)
        iflag=0
   10   deallocate(jtnode,jbndry,jtdof,iuvptr,itedge,ibedge,
     +      vx0,vy0,ut,vt,jord,sf0)
   20   if(iflag==0) then
            sp(11)='triplt: ok'
        else if(iflag==24) then
            write(unit=sp(11),fmt='(a12,i3,a8,i4)')
     +          'triplt error',iflag,': region',ip(24)
        else if(iflag==25) then
            write(unit=sp(11),fmt='(a12,i3,a23)')
     +          'triplt error',iflag,': wrong data structure'
        else
            write(unit=sp(11),fmt='(a12,i3,a22)')
     +          'triplt error',iflag,': insufficient storage'
        endif
c
        ip(25)=iflag
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine clenut(ntf,itdof,len)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(3) :: iords
cy
        len=1
        do i=1,ntf
            call locord(i,ndof,iord,iords,itdof)
            len=len+ndof
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine inplt(vx,vy,sf,itnode,ibndry,itdof,ip,rp,sp,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(22) :: kdist
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(3) :: ia
            integer(kind=iknd), allocatable, dimension(:,:) ::
     +          jtnode,jbndry,jtdof,itedge,ibedge
            integer(kind=iknd), allocatable, dimension(:) :: jt,iclr
            real(kind=rknd), allocatable, dimension(:) :: vx0,vy0
            real(kind=rknd), allocatable, dimension(:,:) :: sf0
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(2) :: ut,vt
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(25) :: t,tl
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(4096) :: red,green,blue
            character(len=80), dimension(100) :: sp
cy
            external sxy
c
c       draw input data
c
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        inplsw=ip(53)
        icrsn=ip(68)
        itrgt=ip(69)
        mpisw=ip(48)
        nproc=ip(49)
        irgn=ip(50)
        if(mpisw==1) then
            mpirgn=ip(47)
            if(mpirgn/=0) then
                if(mpirgn/=irgn) return
                mpisw=-1
            endif
            if(itnode(4,1)==0) mpisw=0
        endif
        do i=1,ntf
            nproc=max(nproc,itnode(4,i))
        enddo
        nrl=ip(13)
        iprob=abs(ip(6))
        if(iprob==4) then
            do i=1,nrl
                rl(i)=rp(90+i)
            enddo
        else if(iprob==6) then
            rl(1)=rp(46)
        else
            rl(1)=rp(21)
        endif
c
        ip(25)=0
c
c       initialize
c
        if(itnode(3,1)==0) then
            if(mpisw==1.and.irgn/=1) return
            if(inplsw==1) then
                iclrsw=1
            else if(inplsw==2) then
                iclrsw=2
            else
                iclrsw=0
            endif
c
            nvv=nvf+3*nbf
            ntt=2*nvv
c
            allocate(jtnode(5,ntt),jbndry(7,nbf),jtdof(8,1),
     +          itedge(3,ntt),ibedge(2,nbf),iclr(ntt),jt(ntf+1),
     1          vx0(nvf),vy0(nvf),sf0(2,nbf))
c
            call cpds(1_iknd,nvf,nbf,itnode,ibndry,itdof,vx,vy,sf,
     +          jtnode,jbndry,jtdof,vx0,vy0,sf0)
c
            call mktris(nbf,nvv,ip,vx0,vy0,jbndry,itnode,
     +          sf0,jt,jtnode,itedge,ntt,iclrsw,nrl,rl,sxy)
            call cedge3(nvf,ntt,nbf,jtnode,jbndry,ibedge,iflag)
            call binits(ip,rp,vx,vy,sf,jtnode,jbndry,
     +          t,tl,q,jp,iclr,ntt,nrl,rl,sxy)
        else
c
            if(ip(5)/=0) then
                call stor(ip,rp)
                call dschek(vx,vy,sf,itnode,ibndry,ip,rp,sp,sxy)
                if(ip(25)/=0) return
c
c           setup itdof
c
                ntf=ip(1)
                nvf=ip(2)
                nbf=ip(3)
c
                call mkdof(ntf,nvf,nbf,ip,itnode,ibndry,itdof)
            endif
c
            if(mpisw==1) then
                if(icrsn==1) then
                    ia(1)=max(4*itrgt,ntf)
                    ia(2)=max(2*itrgt,nbf)
                    ia(3)=max(2*itrgt,nvf)
                else
                    ia(1)=ntf*nproc
                    ia(2)=nbf*nproc
                    ia(3)=nvf*nproc
                endif
                call exsze(ia,0_iknd)
                lent=ia(1)
                lenb=ia(2)
                lenv=ia(3)
            else
                lent=ntf
                lenb=nbf
                lenv=nvf
            endif
c
            allocate(jtnode(5,lent),jbndry(7,lenb),jtdof(8,lent),
     +          itedge(3,lent),ibedge(2,lenb),iclr(lent),jt(2),
     1          vx0(lenv),vy0(lenv),sf0(2,lenb))
c
            call cpds(ntf,nvf,nbf,itnode,ibndry,itdof,vx,vy,sf,
     +          jtnode,jbndry,jtdof,vx0,vy0,sf0)
c
            call binitt(lent,ip,rp,jtnode,itedge,jbndry,ibedge,
     +          jtdof,vx0,vy0,sf0,iclr,kdist,t,tl,q,jp,
     1          nrl,rl,sxy)
        endif
c
        if(mpisw==1.and.itnode(3,1)/=0) then
            ia(1)=jp(1)
            ia(2)=jp(2)
            ia(3)=jp(3)
            call exsze(ia,1_iknd)
            ntf=ia(1)
            nvf=ia(2)
            nbf=ia(3)
            iflag=0
            if(ntf>lent) iflag=83
            if(nvf>lenv) iflag=84
            if(nbf>lenb) iflag=86
            if(iflag/=0) go to 10
            call glbpix(vx0,vy0,sf0,jbndry,jtnode,iclr,ia,
     +          ut,vt,jp,0_iknd)
            if(irgn==1) then
                call cedge1(nvf,ntf,nbf,jtnode,jbndry,itedge,
     +              ibedge,iflag)
            else
                iflag=0
                go to 10
            endif
        endif
c
        call clrmap(red,green,blue,jp)
        call pltutl(jp(18),red,green,blue)
c
c       main plot
c
        call pframe(4_iknd)
        call title0(sp(2),0_iknd)
        call pframe(-4_iknd)
        call pframe(5_iknd)
        call tplot(vx0,vy0,jbndry,jtnode,sf0,t,jp,
     +      itedge,iclr,nrl,rl,sxy)
        if(itnode(3,1)==0) then
            if(jp(21)==1) call rlabel(jp,jtnode,jt,vx,vy,q,t)
            if(jp(21)==2) then
                llen=jp(2)
                call vlabel(llen,jp,jtnode,itedge,jbndry,
     +              ibedge,vx0,vy0,sf0,q,t)
            endif
            if(jp(21)>=3) call blabel(jp,jtnode,jbndry,
     +          ibedge,vx0,vy0,sf0,q,t,nrl,rl,sxy)
        else
            if(jp(21)==1.or.jp(21)==10) then
                call tlabel(jp,jtnode,itdof,vx0,vy0,q,t)
            endif
            if(jp(21)==2.or.jp(21)==8) then
                llen=jp(2)
                call vlabel(llen,jp,jtnode,itedge,jbndry,
     +              ibedge,vx0,vy0,sf0,q,t)
            endif
            if(jp(21)==9) then
               ndf=ip(4)
               call dlabel(ndf,jp,jtnode,itdof,vx0,vy0,q,t)
            endif
            if(jp(21)>=3.and.jp(21)<=6) call blabel(jp,jtnode,
     +          jbndry,ibedge,vx0,vy0,sf0,q,t,nrl,rl,sxy)
            if(jp(21)==7) call plabel(nproc,jp,jtnode,vx0,vy0,q,t)
        endif
        call pframe(-5_iknd)
c
c       legend
c
        call pframe(2_iknd)
        if(jp(9)<=0) then
            call legnd1(jp)
        else if(jp(9)==1) then
            call legnd1(jp)
        else if(jp(9)==6) then
            call legnd5(jp,kdist)
        else if(jp(9)==7) then
            call legnd4(jp,tl,kdist)
        else
            call legnd2(jp,tl)
        endif
        call pframe(-2_iknd)
c
c       small plot
c
        call pframe(3_iknd)
        jp(20)=1
        call tplot(vx0,vy0,jbndry,jtnode,sf0,tl,jp,
     +      itedge,iclr,nrl,rl,sxy)
        call legnd0(t)
        call pframe(-3_iknd)
c
        call pltutl(-1_iknd,red,green,blue)
        iflag=0
   10   deallocate(jtnode,jbndry,jtdof,itedge,ibedge,iclr,
     +      vx0,vy0,sf0,jt)
        if(iflag==0) then
            sp(11)='inplt: ok'
        else if(iflag==20) then
            write(unit=sp(11),fmt='(a11,i3,a22)')
     +          'inplt error',iflag,': insufficient storage'
        else if(iflag==24) then
            write(unit=sp(11),fmt='(a11,i3,a8,i4)')
     +          'inplt error',iflag,': region',ip(24)
        else
            write(unit=sp(11),fmt='(a11,i3,a16)')
     +          'inplt error',iflag,': bad input data'
        endif
c
        ip(25)=iflag
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine setfun(ntf,nvf,nbf,ndf,maxd,ngf,itype,icont,icplt,
     +      u,v1,v2,e,vx,vy,sf,iuvptr,ut,vt,itnode,ibndry,nrl,rl,itdof,
     1      qxy,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(3,ntf) :: icurv
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(2,nbf) :: ibedge
            integer(kind=iknd), dimension(2,*) :: iuvptr
            integer(kind=iknd), dimension(3) :: iords
            real(kind=rknd), dimension(*) :: vx,vy,u,v1,v2,ut,vt,e
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(ndf) :: gm
            real(kind=rknd), dimension(ndf,2) :: ua
            real(kind=rknd), dimension(4,100) :: qv
            real(kind=rknd), dimension(100) :: gv,gx,gy,xp,yp
            real(kind=rknd), dimension(3) :: tx,ty,x,y,xn,yn
            real(kind=rknd), dimension(3,100) :: c
            real(kind=rknd), dimension(10) :: rl
cy
            external qxy,sxy
c
c
        iuvptr(1,1)=1
        do i=1,ntf
            call locord(i,ndof,iord,iords,itdof)
            iuvptr(1,i+1)=iuvptr(1,i)+ndof
            iuvptr(2,i)=itdof(8,i)
            do j=iuvptr(1,i),iuvptr(1,i+1)-1
                ut(j)=0.0e0_rknd
                vt(j)=0.0e0_rknd
            enddo
        enddo
c
c       scalar function
c
        if(itype<1.or.itype>6) then
            icplt=1
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                js=iuvptr(1,i)-1
                do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                    ut(js+j)=u(idof(j))
                enddo
            enddo
c
c       scalar function, plot grad u
c
        else if(itype==1.or.itype==2) then
            icplt=0
            if(itype==1) icplt=1
            call cedge3(nvf,ntf,nbf,itnode,ibndry,ibedge,iflag)
            call ccurv(ntf,nbf,ibndry,ibedge,icurv)
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                call cnode0(c,iord,iords)
                call afmap(i,itnode,vx,vy,tx,ty,x,y,det)
                call cnode2(i,itnode,ibndry,itdof,icurv,vx,vy,
     +              nrl,rl,sf,xp,yp,isw,sxy)
                js=iuvptr(1,i)-1
                do j=1,ndof
                    call beval(c(1,j),x,y,gv,gx,gy,iord,iords)
c
c       isoparamtric map for elements with curved edges
c
                    if(isw/=0) then
                        p11=0.0e0_rknd
                        p12=0.0e0_rknd
                        p21=0.0e0_rknd
                        p22=0.0e0_rknd
                        do m=1,ndof
                            p11=p11+xp(m)*gx(m)
                            p12=p12+xp(m)*gy(m)
                            p21=p21+yp(m)*gx(m)
                            p22=p22+yp(m)*gy(m)
                        enddo
                        detn=p11*p22-p12*p21
                        do m=1,3
                            xn(m)=(p22*x(m)-p21*y(m))/detn
                            yn(m)=(p11*y(m)-p12*x(m))/detn
                        enddo
                        call beval(c(1,j),xn,yn,gv,gx,gy,iord,iords)
                    endif
                    ux=0.0e0_rknd
                    uy=0.0e0_rknd
                    do k=1,ndof
                        ux=ux+u(idof(k))*gx(k)
                        uy=uy+u(idof(k))*gy(k)
                    enddo
                    if(itype==2) then
                        ut(js+j)=ux
                        vt(js+j)=uy
                    else
                        ut(js+j)=sqrt(ux**2+uy**2)
                    endif
                enddo
            enddo
c
c       user function qxy
c
        else if(itype==3.or.itype==4) then
            icplt=0
            if(itype==3) icplt=1
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                call cnode0(c,iord,iords)
                call eleufn(i,itnode,vx,vy,maxd,ngf,u,rl,
     +              ndof,qv,c,itdof,qxy)
                js=iuvptr(1,i)-1
                if(itype==3) then
                    do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                        ut(js+j)=qv(1,j)
                    enddo
                else
                    do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                        ut(js+j)=qv(2,j)
                        vt(js+j)=qv(3,j)
                    enddo
                endif
            enddo
c
c       piecewise constant function defined on elements
c
        else if(itype==5) then
            icplt=1
            do i=1,ntf
                js=iuvptr(1,i)-1
                do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                    ut(js+j)=e(i)
                enddo
            enddo
c
c       vector function
c
        else if(itype==6) then
            icplt=0
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                js=iuvptr(1,i)-1
                do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                    ut(js+j)=v1(idof(j))
                    vt(js+j)=v2(idof(j))
                enddo
            enddo
        endif
c
c       average discontinuous function
c
        if(icont==0) return
        if(icplt==1) then
            do i=1,ndf
                ua(i,1)=0.0e0_rknd
                gm(i)=0.0e0_rknd
            enddo
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                area=abs((vx(itnode(2,i))-vx(itnode(1,i)))*
     +              (vy(itnode(3,i))-vy(itnode(1,i)))-
     1              (vx(itnode(3,i))-vx(itnode(1,i)))*
     2              (vy(itnode(2,i))-vy(itnode(1,i))))
                js=iuvptr(1,i)-1
                do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                    gm(idof(j))=gm(idof(j))+area
                    ua(idof(j),1)=ua(idof(j),1)+area*ut(js+j)
                enddo
            enddo
            do i=1,ndf
                ua(i,1)=ua(i,1)/gm(i)
            enddo
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                js=iuvptr(1,i)-1
                do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                    ut(js+j)=ua(idof(j),1)
                enddo
            enddo
        else
            do i=1,ndf
                ua(i,1)=0.0e0_rknd
                ua(i,2)=0.0e0_rknd
                gm(i)=0.0e0_rknd
            enddo
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                area=abs((vx(itnode(2,i))-vx(itnode(1,i)))*
     +              (vy(itnode(3,i))-vy(itnode(1,i)))-
     1              (vx(itnode(3,i))-vx(itnode(1,i)))*
     2              (vy(itnode(2,i))-vy(itnode(1,i))))
                js=iuvptr(1,i)-1
                do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                    gm(idof(j))=gm(idof(j))+area
                    ua(idof(j),1)=ua(idof(j),1)+area*ut(js+j)
                    ua(idof(j),2)=ua(idof(j),2)+area*vt(js+j)
                enddo
            enddo
            do i=1,ndf
                ua(i,1)=ua(i,1)/gm(i)
                ua(i,2)=ua(i,2)/gm(i)
            enddo
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                js=iuvptr(1,i)-1
                do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                    ut(js+j)=ua(idof(j),1)
                    vt(js+j)=ua(idof(j),2)
                enddo
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine fqual(itri,iedge,icplt,iuvptr,ut,vt,umax,vmax,qual)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(2,*) :: iuvptr
            real(kind=rknd), dimension(*) :: ut,vt
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       test geometry
c
        qual=0.0e0_rknd
        if(iedge==0) return
        ss=0.1e0_rknd
        ii=iuvptr(1,itri)-1
        u2=ut(ii+index(2,iedge))
        u3=ut(ii+index(3,iedge))
        qual=abs(u2-u3)/(abs(u2)+abs(u3)+ss*umax)
        if(icplt/=1) then
            v2=vt(ii+index(2,iedge))
            v3=vt(ii+index(3,iedge))
            qual=abs(v2-v3)/(abs(v2)+abs(v3)+ss*vmax)+qual
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine crsn1(mlen,ntf,nvf,nbf,ndf,ndtrgt,icplt,itnode,
     +      ibndry,itdof,vx,vy,sf,nrl,rl,iuvptr,ut,vt,maxua,va,itedge,
     1      ibedge,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(2,*) :: ibedge,iuvptr
            integer(kind=iknd), dimension(mlen) :: vtype,iseed,
     +          p,q,mark,list
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(500) :: elist,tlist,vlist,
     +          blist,elist0,tlist0,vlist0,blist0
            integer(kind=iknd), dimension(3) :: ibmptr,iords,iv
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(maxua,*) :: va
            real(kind=rknd), dimension(*) :: vx,vy,ut,vt
            real(kind=rknd), dimension(3) :: bump,e
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(mlen) :: qual
cy
            external sxy
c
c       check to see if we have solved problem on current finest grid
c
        call crsn2(ntf,nvf,ndf,ndtrgt,icplt,itdof,iuvptr,ut,vt)
        if(ndf<=ndtrgt) return
        angmin=1.0e-3_rknd
        arcmax=0.26e0_rknd
        iedge=0
c
        umax=0.0e0_rknd
        vmax=0.0e0_rknd
        if(icplt==1) then
            nga=1
            do i=1,iuvptr(1,ntf+1)-1
                umax=max(umax,abs(ut(i)))
            enddo
        else
            nga=2
            do i=1,iuvptr(1,ntf+1)-1
                umax=max(umax,abs(ut(i)))
                vmax=max(vmax,abs(vt(i)))
            enddo
        endif
c
c       initialize iseed, vtype
c
        call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
c
        call cedge5(nbf,itedge,ibedge,1_iknd)
        qmax=0.0e0_rknd
        do i=1,ntf
            call rmtst(i,iedge,itnode,itedge,ibndry,
     +          ibedge,vx,vy,iseed,vtype,1_iknd)
            call fqual(i,iedge,icplt,iuvptr,ut,vt,umax,vmax,qual(i))
            qmax=max(qmax,qual(i))
        enddo
        qmax=100.0e0_rknd*qmax
        do i=1,ntf
            mark(i)=0
            p(i)=i
            q(i)=i
            call rmtst(i,iedge,itnode,itedge,ibndry,
     +          ibedge,vx,vy,iseed,vtype,1_iknd)
            if(iedge==0) then
                qual(i)=-qmax
            else
                qual(i)=-qual(i)
            endif
        enddo
c
c       initialize heap
c
        nn=ntf/2
        do k=nn,1,-1
            call updhp(k,nvf,p,q,qual,0_iknd)
        enddo
        last=ntf
c
c       main elimination loop
c
        last=ntf
        ndf0=maxua
c
c       main elimination loop
c
        do nn=ntf,1,-1
            i=p(1)
            if(qual(i)<=-qmax) exit
            p(1)=p(last)
            p(last)=i
            q(p(last))=last
            q(p(1))=1
            last=last-1
            call updhp(1_iknd,last,p,q,qual,0_iknd)
c
            call locord(i,ndof,iord,iords,itdof)
            if(ndf0-iord**2/2<=ndtrgt) exit
            call rmtst(i,iedge,itnode,itedge,ibndry,
     +          ibedge,vx,vy,iseed,vtype,1_iknd)
            if(iedge==0) stop 4144
            call rmknot(iedge,i,iv,itnode,itedge,ibndry,
     +          ibedge,itdof,vx,vy,sf,1_iknd,nga,maxua,va,ibmptr,
     1          bump,1_iknd,e,iseed,vtype,incdf,-1_iknd,nrl,rl,sxy)
            ndf0=ndf0+incdf
            jtri=iv(3)
            if(jtri>0) then
                kk=q(jtri)
                if(kk==last) then
                    last=last-1
                else
                    p(kk)=p(last)
                    p(last)=jtri
                    q(p(last))=last
                    q(p(kk))=kk
                    last=last-1
                    call updhp(kk,last,p,q,qual,1_iknd)
                endif
            endif
c
c       update vertices in connected to i
c
            llen=0
            do m=1,2
                if(iv(m)==0) cycle
c
                call cirlst(iv(m),itnode,itedge,ibndry,ibedge,
     +              iseed,vtype,vlist,tlist,elist,blist,len)
                call tstvty(iv(m),itnode,ibndry,vx,vy,sf,itedge,
     +              vtype,angmin,arcmax,vlist,tlist,elist,len)
                do jj=1,len
                    j=vlist(jj)
                    if(j==0) cycle
                    call cirlst(j,itnode,itedge,ibndry,ibedge,
     +                  iseed,vtype,vlist0,tlist0,elist0,blist0,len0)
                    call tstvty(j,itnode,ibndry,vx,vy,sf,itedge,
     +                  vtype,angmin,arcmax,vlist0,tlist0,elist0,len0)
                    js=1
                    if(vtype(j)>=7) js=2
                    do kk=js,len0
                        k=tlist0(kk)
                        if(mark(k)/=nn) then
                            llen=llen+1
                            list(llen)=k
                            mark(k)=nn
                        endif
                    enddo
                enddo
            enddo
            do m=1,llen
                j=list(m)
                call rmtst(j,iedge,itnode,itedge,ibndry,
     +              ibedge,vx,vy,iseed,vtype,1_iknd)
                if(iedge>0) then
                    call fqual(j,iedge,icplt,iuvptr,ut,vt,umax,vmax,qq)
                    qual(j)=-qq
                else
                    qual(j)=-qmax
                endif
                kk=q(j)
                call updhp(kk,last,p,q,qual,1_iknd)
            enddo
        enddo
        call clnup1(nvf,ntf,nbf,ndf,itnode,itedge,ibndry,ibedge,
     +      vx,vy,sf,maxua,va,icplt,iseed,itdof)
c
c       improve geometry
c
        call eswapa(ntf,nvf,nbf,nga,1_iknd,itnode,itedge,ibndry,ibedge,
     +      vx,vy,ibmptr,bump,1_iknd,e,0_iknd,1_iknd,itdof,maxua,va)
        call cedge5(nbf,itedge,ibedge,0_iknd)
c
        if(icplt==1) then
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                js=iuvptr(1,i)-1
                do j=1,ndof
                    ut(js+j)=va(idof(j),1)
                enddo
            enddo
        else
            do i=1,ntf
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                js=iuvptr(1,i)-1
                do j=1,ndof
                    ut(js+j)=va(idof(j),1)
                    vt(js+j)=va(idof(j),2)
                enddo
            enddo
        endif
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine crsn2(ntf,nvf,ndf,ndtrgt,icplt,itdof,iuvptr,ut,vt)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(2,*) :: iuvptr
            integer(kind=iknd), dimension(ntf) :: torder
            integer(kind=iknd), dimension(10) :: iptr
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(3) :: iords,jords
            real(kind=rknd), dimension(*) :: ut,vt
            real(kind=rknd), dimension(100) :: gq
cy
c       reduce dimension by reducing degree of approximation
c
c       order elements by degree
c
        mxord=9
        do i=1,mxord+1
            iptr(i)=0
        enddo
        do itri=1,ntf
            call locord(itri,ndof,iord,iords,itdof)
            iptr(iord+1)=iptr(iord+1)+1
        enddo
        iptr(1)=1
        do i=2,mxord+1
            iptr(i)=iptr(i)+iptr(i-1)
        enddo
        do itri=1,ntf
            call locord(itri,ndof,iord,iords,itdof)
            torder(iptr(iord))=itri
            iptr(iord)=iptr(iord)+1
        enddo
        do i=mxord,2,-1
            iptr(i)=iptr(i-1)
        enddo
        iptr(1)=1
c
c       reduce degrees
c
        ndf1=iuvptr(1,ntf+1)-1
        do mord=mxord,2,-1
            do ii=ntf,iptr(mord),-1
                itri=torder(ii)
                call locord(itri,ndof,iord,iords,itdof)
                jord=iord-1
                do j=1,3
                    jords(j)=jord
                enddo
                jdof=((jord+1)*(jord+2))/2
                kk=iuvptr(1,itri)
                call p2q2d(ut(kk),gq,iord,jord,iords,jords)
                do j=1,jdof
                    ut(kk+j-1)=gq(j)
                enddo
                if(icplt/=1) then
                    call p2q2d(vt(kk),gq,iord,jord,iords,jords)
                    do j=1,jdof
                        vt(kk+j-1)=gq(j)
                    enddo
                endif
                ndf1=ndf1-(ndof-jdof)
                iuvptr(2,itri)=jord*(1+16+16**2+16**3)
                itdof(8,itri)=iuvptr(2,itri)
            enddo
            if(ndf1<ndtrgt) exit
        enddo
c
c       clean up
c
        iold=iuvptr(1,1)
        inew=iuvptr(1,1)
        do itri=1,ntf
            call locord(itri,ndof,iord,iords,itdof)
            do i=1,ndof
                ut(inew+i-1)=ut(iold+i-1)
            enddo
            if(icplt/=1) then
                do i=1,ndof
                    ut(inew+i-1)=ut(iold+i-1)
                enddo
            endif
            iold=iuvptr(1,itri+1)
            iuvptr(1,itri+1)=inew+ndof
            inew=iuvptr(1,itri+1)
            iuvptr(2,itri)=itdof(8,itri)
        enddo
        if(ndtrgt<nvf) then
            ndf=nvf
        else
            ndf2=iuvptr(1,ntf+1)-1
            qq=real(ndf,rknd)*(real(ndf2,rknd)/real(ndf1,rknd))
            ndf=min(int(qq),ndtrgt)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine clnup1(nvf,ntf,nbf,ndf,itnode,itedge,ibndry,ibedge,
     +      vx,vy,sf,maxua,va,icplt,mark,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) :: iords
            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), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(100) :: idof
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(maxua,*) :: va
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
                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       now fix vertex arrays
c
        do i=1,nvf
            mark(i)=0
        enddo
        do i=1,ntf
            do j=1,3
                mark(itnode(j,i))=1
            enddo
        enddo
        nvnew=0
        do i=1,nvf
            if(mark(i)/=0) then
                nvnew=nvnew+1
                mark(i)=nvnew
                vx(nvnew)=vx(i)
                vy(nvnew)=vy(i)
            endif
        enddo
        nvf=nvnew
        do i=1,ntf
            do j=1,3
                itnode(j,i)=mark(itnode(j,i))
            enddo
        enddo
        do i=1,nbf
            do j=1,2
                ibndry(j,i)=mark(ibndry(j,i))
            enddo
        enddo
c
c       now fix dofs
c
        do i=1,ndf
            mark(i)=0
        enddo
        do i=1,ntf
            call l2gmap(i,idof,ndof,iord,iords,itdof)
            do j=1,ndof
                mark(idof(j))=1
            enddo
        enddo
        ndnew=0
        do i=1,ndf
            if(mark(i)==0) cycle
            ndnew=ndnew+1
            mark(i)=ndnew
            va(ndnew,1)=va(i,1)
            if(icplt/=1) va(ndnew,2)=va(i,2)
        enddo
        ndf=ndnew
        do i=1,ntf
            call l2gmap(i,idof,ndof,iord,iords,itdof)
            do j=1,ndof
                idof(j)=mark(idof(j))
            enddo
            call g2lmap(i,idof,itdof)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cvz(ntf,ndf,icplt,vx,vy,iuvptr,ut,vt,
     +      itnode,itdof,maxua,va)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(3) :: iords
            integer(kind=iknd), dimension(2,*) :: iuvptr
            real(kind=rknd), dimension(*) :: vx,vy,ut,vt
            real(kind=rknd), dimension(ndf) :: gm
            real(kind=rknd), dimension(maxua,*) :: va
cy
        if(icplt==1) then
            do i=1,ndf
                va(i,1)=0.0e0_rknd
                gm(i)=0.0e0_rknd
            enddo
            do i=1,ntf
                area=abs((vx(itnode(2,i))-vx(itnode(1,i)))*
     +              (vy(itnode(3,i))-vy(itnode(1,i)))-
     1              (vx(itnode(3,i))-vx(itnode(1,i)))*
     2              (vy(itnode(2,i))-vy(itnode(1,i))))
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                js=iuvptr(1,i)-1
                do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                    ivj=idof(j)
                    gm(ivj)=gm(ivj)+area
                    va(ivj,1)=va(ivj,1)+area*ut(js+j)
                enddo
            enddo
            do i=1,ndf
                va(i,1)=va(i,1)/gm(i)
            enddo
        else
            do i=1,ndf
                va(i,1)=0.0e0_rknd
                va(i,2)=0.0e0_rknd
                gm(i)=0.0e0_rknd
            enddo
            do i=1,ntf
                area=abs((vx(itnode(2,i))-vx(itnode(1,i)))*
     +              (vy(itnode(3,i))-vy(itnode(1,i)))-
     1              (vx(itnode(3,i))-vx(itnode(1,i)))*
     2              (vy(itnode(2,i))-vy(itnode(1,i))))
                call l2gmap(i,idof,ndof,iord,iords,itdof)
                js=iuvptr(1,i)-1
                do j=1,iuvptr(1,i+1)-iuvptr(1,i)
                    ivj=idof(j)
                    gm(ivj)=gm(ivj)+area
                    va(ivj,1)=va(ivj,1)+area*ut(js+j)
                    va(ivj,2)=va(ivj,2)+area*vt(js+j)
                enddo
            enddo
            do i=1,ndf
                va(i,1)=va(i,1)/gm(i)
                va(i,2)=va(i,2)/gm(i)
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cpds(ntf,nvf,nbf,itnode,ibndry,itdof,vx,vy,sf,
     +      jtnode,jbndry,jtdof,vx0,vy0,sf0)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode,jtnode
            integer(kind=iknd), dimension(7,*) :: ibndry,jbndry
            integer(kind=iknd), dimension(8,*) :: itdof,jtdof
            real(kind=rknd), dimension(*) :: vx,vy,vx0,vy0
            real(kind=rknd), dimension(2,*) :: sf,sf0
cy
c       copy data structures
c
        do i=1,ntf
             do j=1,5
                jtnode(j,i)=itnode(j,i)
             enddo
             do j=1,8
                jtdof(j,i)=itdof(j,i)
             enddo
        enddo
        do i=1,nbf
            do j=1,7
                jbndry(j,i)=ibndry(j,i)
            enddo
            do j=1,2
                sf0(j,i)=sf(j,i)
            enddo
        enddo
        do i=1,nvf
            vx0(i)=vx(i)
            vy0(i)=vy(i)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cplot(jp,itnode,ibndry,itedge,order,
     +      vx,vy,iuvptr,ut,sf,q,t,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3072) :: ibdy
            integer(kind=iknd), dimension(*) :: order
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(2,*) :: iuvptr
            real(kind=rknd), dimension(*) :: vx,vy,ut
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(9) :: x,y,z,f,x0,y0,z0,f0
            real(kind=rknd), dimension(3) :: bx,by,bz,bf,xt,yt,zt
            real(kind=rknd), dimension(3072) :: xp,yp,up,vp
cy
            external sxy
            data index/1,2,3,2,3,1,3,1,2/
c
c       color surface plot
c       initialize
c
        ntf=jp(1)
        ncolor=jp(5)
        nshade=jp(16)
        ishade=0
        iscale=jp(19)
        lines=jp(20)
        i3d=jp(22)
c
        pi=3.141592653589793e0_rknd
        xshift=t(1)
        yshift=t(2)
        zshift=t(5)
        scale=t(3)
        if(i3d==0) then
            zratio=0.0e0_rknd
        else
            zratio=t(4)
        endif
        eps=t(7)
        smin=t(19)
        smax=t(20)
        zmin=fscale(smin,iscale,0_iknd)
        zmax=fscale(smax,iscale,0_iknd)
        smin=smin-abs(smin)*eps
        smax=smax+abs(smax)*eps
        if(zmax>zmin) then
            zscale=(1.0e0_rknd-eps)*real(ncolor,rknd)/(zmax-zmin)
        else
            zscale=0.0e0_rknd
        endif
c
c       shading (reset (dxx,dyy,dzz) for a different light source)
c
        if(nshade>0) then
            dxx=q(1,3)
            dyy=q(2,3)
            dzz=q(3,3)
            dd=sqrt(dxx*dxx+dyy*dyy+dzz*dzz)
            dxx=dxx/dd
            dyy=dyy/dd
            dzz=dzz/dd
        endif
c
c
c       the main loop
c
        do ii=1,ntf
c
c     compute triangle boundary
c
            it=order(ii)
            call tbdy(xp,yp,up,vp,ibdy,ntri,it,itnode,ibndry,itedge,
     +          vx,vy,sf,q,i3d,1_iknd,iuvptr,ut,ut,nrl,rl,sxy)
c
c       set up coordinates, scale bv to lie on (0,ncolor)
c
            do itri=1,3*ntri,3
                do mm=1,3
                    m=mm+itri-1
                    xt(mm)=xp(m)
                    yt(mm)=yp(m)
                    zt(mm)=up(m)
                    bf(mm)=(fscale(zt(mm),iscale,0_iknd)-zmin)*zscale
                    bf(mm)=max(bf(mm),-1.0e0_rknd)
                    bf(mm)=min(bf(mm),real(ncolor+1,rknd))
                    zt(mm)=zt(mm)*zratio
                    xxm=q(1,1)*xt(mm)+q(2,1)*yt(mm)
                    yym=q(1,2)*xt(mm)+q(2,2)*yt(mm)+q(3,2)*zt(mm)
                    zzm=q(1,3)*xt(mm)+q(2,3)*yt(mm)+q(3,3)*zt(mm)
                    bx(mm)=xxm*scale+xshift
                    by(mm)=yym*scale+yshift
                    bz(mm)=zzm*scale+zshift
                enddo
c
c       compute the shade
c
                if(nshade>0) then
                    x2=xt(2)-xt(1)
                    y2=yt(2)-yt(1)
                    z2=zt(2)-zt(1)
                    x3=xt(3)-xt(1)
                    y3=yt(3)-yt(1)
                    z3=zt(3)-zt(1)
                    xx=y2*z3-y3*z2
                    yy=z2*x3-z3*x2
                    zz=x2*y3-x3*y2
                    qq=sqrt(xx*xx+yy*yy+zz*zz)
                    aa=(dxx*xx+dyy*yy+dzz*zz)/qq
                    aq=(q(1,3)*xx+q(2,3)*yy+q(3,3)*zz)/qq
                    if(aa*aq<0.0e0_rknd) then
                        ishade=-nshade
                    else
                        aa=min(1.0e0_rknd,abs(aa))
                        aa=(1.0e0_rknd-4.0e0_rknd*acos(aa)/pi)*
     +                      real(nshade+1,rknd)
                        ishade=min(int(abs(aa)),nshade)
                        if(aa<0.0e0_rknd) ishade=-ishade
                    endif
                endif
c
c        order function values
c
                kmin=1
                if(bf(kmin)>bf(2)) kmin=2
                if(bf(kmin)>bf(3)) kmin=3
                kmid=index(2,kmin)
                kmax=index(3,kmin)
                if(bf(kmid)>bf(kmax)) kmid=kmax
                kmax=6-kmin-kmid
c
c      find min and max color values for this triangle
c
                mnc=int(bf(kmin))+1
                mxc=int(bf(kmax))+1
                if(bf(kmax)==real(mxc-1,rknd)) mxc=max(mxc-1,mnc)
c
                do mm=mnc,mxc
                    do m=1,3
                        x(m)=bx(m)
                        y(m)=by(m)
                        z(m)=bz(m)
                        f(m)=bf(m)
                    enddo
                    len=3
                    cc=-1.0e0_rknd
                    do j=mm-1,mm
                        cc=-cc
                        len0=len
                        len=0
                        do m=1,len0
                            x0(m)=x(m)
                            y0(m)=y(m)
                            z0(m)=z(m)
                            f0(m)=f(m)
                        enddo
                        do m=1,len0
                            sm=(f0(m)-real(j,rknd))*cc
                            if(sm>=0.0e0_rknd) then
                                len=len+1
                                x(len)=x0(m)
                                y(len)=y0(m)
                                z(len)=z0(m)
                                f(len)=f0(m)
                            else
                                k=m-1
                                if(m==1) k=len0
                                kaft=m+1
                                if(m==len0) kaft=1
                                do kba=1,2
                                    sk=(f0(k)-real(j,rknd))*cc
                                    if(sk>0.0e0_rknd) then
                                        len=len+1
                                        s=sk/(sk-sm)
                                        x(len)=x0(m)*s
     +                                      +x0(k)*(1.0e0_rknd-s)
                                        y(len)=y0(m)*s
     +                                      +y0(k)*(1.0e0_rknd-s)
                                        z(len)=z0(m)*s
     +                                      +z0(k)*(1.0e0_rknd-s)
                                        f(len)=f0(m)*s
     +                                      +f0(k)*(1.0e0_rknd-s)
                                    endif
                                    k=kaft
                                enddo
                            endif
                        enddo
                    enddo
                    if(len>2) then
                        mc=ccolor(mm,ishade,jp)
                        call pwindw(x,y,z,len,t,mc)
                    endif
                enddo
c
c        contour lines
c
                if(lines/=3) go to 10
                if(bf(kmin)>=bf(kmax)) go to 10
                mnc=int(bf(kmin))+1
                if(bf(kmin)>real(mnc-1,rknd)) mnc=mnc+1
                mxc=min(ncolor,int(bf(kmax)))+1
c
c       move boundary edges slightly into the interior...
c
                do m=mnc,mxc
                    s=(bf(kmax)-real(m-1,rknd))/(bf(kmax)-bf(kmin))
                    s=max(0.02e0_rknd,s)
                    s=min(0.98e0_rknd,s)
                    x(1)=bx(kmin)*s+bx(kmax)*(1.0e0_rknd-s)
                    y(1)=by(kmin)*s+by(kmax)*(1.0e0_rknd-s)
                    z(1)=bz(kmin)*s+bz(kmax)*(1.0e0_rknd-s)
                    if(bf(kmid)>max(bf(kmin),real(m-1,rknd)))then
                        s=(bf(kmid)-real(m-1,rknd))/(bf(kmid)-bf(kmin))
                        s=max(0.02e0_rknd,s)
                        s=min(0.98e0_rknd,s)
                        x(2)=bx(kmin)*s+bx(kmid)*(1.0e0_rknd-s)
                        y(2)=by(kmin)*s+by(kmid)*(1.0e0_rknd-s)
                        z(2)=bz(kmin)*s+bz(kmid)*(1.0e0_rknd-s)
                    else if(bf(kmid)<bf(kmax)) then
                        s=(bf(kmax)-real(m-1,rknd))/(bf(kmax)-bf(kmid))
                        s=max(0.02e0_rknd,s)
                        s=min(0.98e0_rknd,s)
                        x(2)=bx(kmid)*s+bx(kmax)*(1.0e0_rknd-s)
                        y(2)=by(kmid)*s+by(kmax)*(1.0e0_rknd-s)
                        z(2)=bz(kmid)*s+bz(kmax)*(1.0e0_rknd-s)
                    else
                        x(2)=bx(kmid)
                        y(2)=by(kmid)
                        z(2)=bz(kmid)
                    endif
                    call lwindw(x,y,z,2_iknd,t,2_iknd)
                enddo
c
c        line drawing
c
   10           do m=1,3
                    k=ibdy(itri+m-1)
                    isw=0
                    if(lines==-1) then
                        isw=1
                    else if(lines==0.and.k>=0) then
                        isw=1
                    else if(k==1) then
                        isw=1
                    else if(k>1) then
                        if(lines==1) then
                            if(k==2.or.k==5) isw=1
                        else if(lines==2) then
                            if(k==3.or.k==5) isw=1
                        endif
                    endif
                    if(isw==1) then
                        x(1)=bx(index(2,m))
                        y(1)=by(index(2,m))
                        z(1)=bz(index(2,m))
                        x(2)=bx(index(3,m))
                        y(2)=by(index(3,m))
                        z(2)=bz(index(3,m))
                        call lwindw(x,y,z,2_iknd,t,2_iknd)
                    endif
                enddo
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine vplot(jp,itnode,ibndry,itedge,order,
     +      vx,vy,iuvptr,ut,vt,sf,q,t,nrl,rll,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(2,*) :: iuvptr
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(3072) :: ibdy
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(*) :: order
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy,ut,vt
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(10) :: x,y,z,rll
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3) :: z1,z2,rl
            real(kind=rknd), dimension(8) :: bu,bv,bx,by,bz
            real(kind=rknd), dimension(3,8) :: b
            real(kind=rknd), dimension(3072) :: xp,yp,up,vp
cy
            external sxy
            data index/1,2,3,2,3,1,3,1,2/
c
c       vector plots
c
        i3d=jp(22)
        xshift=t(1)
        yshift=t(2)
        zshift=t(5)
        scale=t(3)
        rmin=t(19)
        rmax=t(20)
        eps=t(7)
        if(i3d==0) then
            zratio=0.0e0_rknd
        else
            zratio=t(4)
        endif
c
        ntf=jp(1)
        ncolor=jp(5)
        nshade=jp(16)
        iscale=jp(19)
        lines=jp(20)
        zmin=fscale(rmin,iscale,0_iknd)
        zmax=fscale(rmax,iscale,0_iknd)
c
        pi=3.141592653589793e0_rknd
        pi2=2.0e0_rknd*pi
        if(nshade>0.and.zmin/=zmax) then
            zscale=(1.0e0_rknd-eps)*real(2*nshade+1,rknd)/(zmax-zmin)
        else
            zscale=0.0e0_rknd
        endif
        zs=(zmax-zmin)/real(2*nshade+1,rknd)
        if(ncolor>0) then
            nr=max(64/ncolor,1)
            nnr=ncolor*nr
            dtheta=pi2/real(nnr,rknd)
        else
            dtheta=2.0e0_rknd*pi2
            nr=1
            nnr=1
        endif
c
c       color triangles
c
        do ij=1,ntf
            i=order(ij)
c
c     lay out polygon
c
            call tbdy(xp,yp,up,vp,ibdy,ntri,i,itnode,ibndry,itedge,
     +          vx,vy,sf,q,i3d,0_iknd,iuvptr,ut,vt,nrl,rll,sxy)
c
            do itri=1,3*ntri,3
                do mm=1,3
                    m=mm+itri-1
                    x(mm)=xp(m)
                    y(mm)=yp(m)
                    z1(mm)=up(m)
                    z2(mm)=vp(m)
                    rl(mm)=sqrt(up(m)**2+vp(m)**2)*zratio
                enddo
                call trnk(irank,z1,z2,rmax,eps)
c
                call gbx(z1,z2,gmin,gmax,tmin,tmax,eps,irank)
                irmin=int((fscale(gmin,iscale,0_iknd)-zmin)*zscale)+1
                irmax=int((fscale(gmax,iscale,0_iknd)-zmin)*zscale)+1
                itmin=int(tmin/dtheta)+1
                itmax=int(tmax/dtheta)+1
                if(irank==1.or.irmax-irmin+itmax-itmin==0) then
                    jrank=1
                else
                    jrank=0
                    irmin=max(1,irmin)
                    irmax=min(2*nshade+1,irmax)
                    if(irmin>irmax) go to 20
                    itmin=max(1,itmin-1)
                    itmax=itmax+1
                endif
c
                do ir=irmin,irmax
                do it=itmin,itmax
c
c        compute color index
c
                    icolor=it-1
                    if(icolor>=nnr) icolor=icolor-nnr
                    icolor=(icolor/nr)+1
                    ishade=ir-nshade-1
                    ii=ccolor(icolor,ishade,jp)
c
c        rank 1 case
c
                    if(jrank==1) then
                        do j=1,3
                            msides=3
                            do k=1,3
                                b(k,j)=0.0e0_rknd
                            enddo
                            b(j,j)=1.0e0_rknd
                        enddo
                    else
c
c       set up box
c
                        t1=real(it-1,rknd)*dtheta
                        t2=real(it,rknd)*dtheta
                        c1=cos(t1)
                        c2=cos(t2)
                        s1=sin(t1)
                        s2=sin(t2)
                        rr1=zmin+real(ir-1,rknd)*zs
                        r1=fscale(rr1,iscale,1_iknd)
                        r1=max(r1,gmin*0.99e0_rknd)
                        rr2=zmin+real(ir,rknd)*zs
                        r2=fscale(rr2,iscale,1_iknd)
                        r2=min(r2,gmax*1.05e0_rknd)
                        bu(1)=r1*c1
                        bv(1)=r1*s1
                        bu(2)=r2*c1
                        bv(2)=r2*s1
                        bu(3)=r2*c2
                        bv(3)=r2*s2
                        bu(4)=r1*c2
                        bv(4)=r1*s2
c
                        if(irank==3) then
                            call tribx3(b,msides,bu,bv,z1,z2)
                        else
                            call tribx2(b,msides,bu,bv,z1,z2)
                        endif
                    endif
                    if(msides<=2) cycle
                    do j=1,msides
                        xx=b(1,j)*x(1)+b(2,j)*x(2)
     +                      +b(3,j)*x(3)
                        yy=b(1,j)*y(1)+b(2,j)*y(2)
     +                      +b(3,j)*y(3)
                        zz=b(1,j)*rl(1)+b(2,j)*rl(2)
     +                      +b(3,j)*rl(3)
c*                      zu=b(1,j)*z1(1)+b(2,j)*z1(2)
c*   +                      +b(3,j)*z1(3)
c*                      zv=b(1,j)*z2(1)+b(2,j)*z2(2)
c*   +                      +b(3,j)*z2(3)
c*                      zz=sqrt(zu**2+zv**2)*zratio
                        xr=q(1,1)*xx+q(2,1)*yy
                        yr=q(1,2)*xx+q(2,2)*yy+q(3,2)*zz
                        zr=q(1,3)*xx+q(2,3)*yy+q(3,3)*zz
                        bx(j)=xr*scale+xshift
                        by(j)=yr*scale+yshift
                        bz(j)=zr*scale+zshift
                    enddo
                    call pwindw(bx,by,bz,msides,t,ii)
                enddo
                enddo
c
c       line drawing options
c
   20           do m=1,3
                    bx(m)=q(1,1)*x(m)+q(2,1)*y(m)
                    by(m)=q(1,2)*x(m)+q(2,2)*y(m)+q(3,2)*rl(m)
                    bz(m)=q(1,3)*x(m)+q(2,3)*y(m)+q(3,3)*rl(m)
                    bx(m)=bx(m)*scale+xshift
                    by(m)=by(m)*scale+yshift
                    bz(m)=bz(m)*scale+zshift
                enddo
                do m=1,3
                    k=ibdy(itri+m-1)
                    isw=0
                    if(lines==-1) then
                        isw=1
                    else if(lines==0.and.k>=0) then
                        isw=1
                    else if(k==1) then
                        isw=1
                    else if(k>1) then
                        if(lines==1) then
                            if(k==2.or.k==5) isw=1
                        else if(lines==2) then
                            if(k==3.or.k==5) isw=1
                        endif
                    endif
                    if(isw==1) then
                        x(1)=bx(index(2,m))
                        y(1)=by(index(2,m))
                        z(1)=bz(index(2,m))
                        x(2)=bx(index(3,m))
                        y(2)=by(index(3,m))
                        z(2)=bz(index(3,m))
                        call lwindw(x,y,z,2_iknd,t,2_iknd)
                    endif
                enddo
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine torder(jp,itnode,itedge,order,ilen,vx,vy,q)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(*) :: order
            integer(kind=iknd), dimension(ilen) :: nblock
            integer(kind=iknd), dimension(4*ilen+1) :: list
            integer(kind=iknd) :: tblock
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(3,3) :: q
cy
c
c       color surface plot
c
        eps=1.0e1_rknd*epsilon(1.0e0_rknd)
        eps1=max(1.0e-4_rknd,eps*8.0e0_rknd)
        iordsw=jp(8)
        ntf=jp(1)
c
        do i=1,ntf
            order(i)=i
        enddo
        if(iordsw==1) return
        if(ntf<=1) return
c
c       find boundary interference list
c
        call bblock(ntf,itnode,itedge,ilen,list,vx,vy,q,eps)
c
c       set up nblock
c
        do i=1,ntf
            nblock(i)=0
        enddo
        do i=1,ntf
            do iside=1,3
               j=itedge(iside,i)/4
               if(j>i) then
                  it=tblock(itnode,i,iside,vx,vy,q,eps1)
                  if(it==1) nblock(i)=nblock(i)+1
                  if(it==-1) nblock(j)=nblock(j)+1
               endif
            enddo
            do jj=list(i),list(i+1)-1
                j=list(jj)
                nblock(j)=nblock(j)+1
            enddo
        enddo
c
c       now compute order
c
        mpt=1
        do i=1,ntf
             if(nblock(i)==0) then
                order(mpt)=i
                nblock(i)=-mpt
                mpt=mpt+1
            endif
        enddo
        if(mpt>ntf) go to 20
c
        do m=1,ntf
            if(m>=mpt) stop 1123
            i=order(m)
c
c       update nblock
c
            if(list(i)<list(i+1)) then
                do jj=list(i),list(i+1)-1
                    j=list(jj)
                    nblock(j)=nblock(j)-1
                    if(nblock(j)==0) then
                        order(mpt)=j
                        nblock(j)=-mpt
                        mpt=mpt+1
                        if(mpt>ntf) go to 20
                    endif
                enddo
            endif
c
            do iside =1,3
                j=itedge(iside,i)/4
                if(j<=0) cycle
                if(nblock(j)<0) cycle
                it=tblock(itnode,i,iside,vx,vy,q,eps1)
                if(it/=-1) cycle
                nblock(j)=nblock(j)-1
                if(nblock(j)==0) then
                    order(mpt)=j
                    nblock(j)=-mpt
                    mpt=mpt+1
                    if(mpt>ntf) go to 20
                endif
            enddo
        enddo
   20   if(jp(1)>=ntf) return
        mpt=0
        newntf=jp(1)
        do i=1,ntf
            if(order(i)>newntf) cycle
            mpt=mpt+1
            order(mpt)=order(i)
        enddo
        if(mpt/=newntf) stop 2255
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine plinit(ip,rp,itnode,ibndry,itdof,itedge,ibedge,vx,vy,
     +      iuvptr,ut,vt,sf,icplt,ierrsw,e,kdist,q,t,tl,jp,maxua,
     1      nrl,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(2,*) :: ibedge,iuvptr
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), dimension(*) :: kdist
            integer(kind=iknd), dimension(8,*) :: itdof
            real(kind=rknd), dimension(*) :: vx,vy,ut,vt,e
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(25) :: t,tl
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), save, dimension(5) :: bmin,bmax
            real(kind=rknd), dimension(maxua,2) :: ua
cy
            external sxy
            data bmin/5*0.0e0_rknd/
            data bmax/5*0.0e0_rknd/
c
c       check control parameters in ip
c
        mpisw=ip(48)
        nproc=ip(49)
        irgn=ip(50)
        if(mpisw==1) then
            mpirgn=ip(47)
            if(mpirgn/=0.and.mpirgn==irgn) mpisw=-1
            if(itnode(4,1)==0) mpisw=0
        endif
        do i=1,25
            jp(i)=0
        enddo
        call linit(t,q)
        call zoombx(rp,t)
        rmag=t(12)
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        ndf=ip(4)
        icrsn=ip(68)
        itrgt=ip(69)
        do i=1,ntf
            nproc=max(nproc,itnode(4,i))
        enddo
c
c
        if(mpisw==1) then
            call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,
     +          ibedge,iflag)
            call cedge5(nbf,itedge,ibedge,1_iknd)
            len=nvf
            call cutr1(len,ntf,nvf,nbf,irgn,itnode,itdof,ibndry,
     +          vx,vy,sf,bmin,iuvptr,ut,vt,ibedge,1_iknd)
        else if(icrsn==1) then
            newnbf=0
            do i=1,nbf
                if(ibndry(4,i)==0) cycle
                newnbf=newnbf+1
                do j=1,7
                    ibndry(j,newnbf)=ibndry(j,i)
                enddo
                ibndry(4,newnbf)=1
                ibndry(5,newnbf)=0
                ibndry(6,newnbf)=0
            enddo
            nbf=newnbf
        endif
        call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag)
c
c       coarsen the mesh
c
        if(icrsn==1) then
            if(mpisw==1) then
                ndtrgt=max(3,itrgt/nproc)
            else
                ndtrgt=max(3,itrgt)
            endif
c
            call cvz(ntf,ndf,icplt,vx,vy,iuvptr,ut,vt,
     +          itnode,itdof,maxua,ua)
c
            llen=max0(ntf,ndf)
            call crsn1(llen,ntf,nvf,nbf,ndf,ndtrgt,icplt,itnode,
     +          ibndry,itdof,vx,vy,sf,nrl,rl,iuvptr,ut,vt,maxua,ua,
     1          itedge,ibedge,sxy)
            call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag)
        endif
c
        iscale=ip(58)
        if(iscale<0.or.iscale>2) iscale=0
        lines=ip(59)
        if(lines<-1.or.lines>3) lines=0
        if(icrsn==1.and.lines==0) lines=1
        numbrs=ip(60)
        if(numbrs<0.or.numbrs>10) numbrs=0
        if(mpisw==1.and.numbrs/=7) numbrs=0
        if(icrsn==1.and.numbrs/=7 ) numbrs=0
        nx=ip(61)
        ny=ip(62)
        nz=ip(63)
        mxcolr=max(2,ip(51))
        mxcolr=min(4096,mxcolr)
        ncolor=max(1,ip(56))
        i3d=1
        if(numbrs/=0) i3d=0
c
c       set up jp
c
        jp(1)=ntf
        jp(2)=nvf
        jp(3)=nbf
        jp(4)=icplt
        jp(5)=ncolor
        jp(6)=ierrsw
        jp(12)=mpisw
c
        jp(13)=nx
        jp(14)=ny
        jp(15)=nz
c
        jp(17)=mxcolr
        jp(20)=lines
        jp(21)=numbrs
        jp(23)=nproc
        jp(24)=ndf
c
c       find a box containing the solution
c
        do i=1,3
            do j=1,3
                q(i,j)=0.0e0_rknd
            enddo
            q(i,i)=1.0e0_rknd
        enddo
        zratio=1.0e0_rknd
        call pbox(ntf,itnode,ibndry,itedge,vx,vy,icplt,
     +      iuvptr,ut,vt,sf,q,zratio,bmin,bmax,rp,nrl,rl,sxy)
c
        if(mpisw==1) call exbox(bmin,bmax,3_iknd)
c
        if(rp(7)<=rp(6)) then
            t(19)=bmin(3)
            t(20)=bmax(3)
        else
            t(19)=rp(6)
            t(20)=rp(7)
        endif
        if(bmax(3)>bmin(3)) then
            t(4)=max(bmax(1)-bmin(1),bmax(2)-bmin(2))/
     +          max(t(20)-t(19),bmax(3)-bmin(3))
        else
            t(4)=0.0e0_rknd
        endif
        if(min(bmin(3),t(19))<=0.0e0_rknd.and.iscale==1) iscale=2
        jp(19)=iscale
c
c
        if(t(4)==0.0e0_rknd) i3d=0
        if(i3d==0) then
            zratio=0.0e0_rknd
        else
            zratio=t(4)
        endif
        jp(22)=i3d
        iordsw=0
        if(i3d==0) iordsw=1
        if(nx==0.and.ny==0) iordsw=1
        jp(8)=iordsw
c
        if(mxcolr==2.or.ncolor==0) then
            maplen=2
            nshade=0
        else
            if(ncolor>=mxcolr-2) then
                nshade=0
                maplen=mxcolr
            else
                nshade=(mxcolr-2)/ncolor
                nshade=(nshade-1)/2
                if(icplt/=0) then
                    if(nx==0.and.ny==0) nshade=0
                    if(numbrs/=0) nshade=0
                    if(zratio<=0.0e0_rknd) nshade=0
                else
                    nshade=min(nshade,5)
                    if(max(abs(t(19)),abs(t(20)))==0.0e0_rknd) nshade=0
                endif
                maplen=2+ncolor*(2*nshade+1)
            endif
        endif
        jp(16)=nshade
        jp(18)=maplen
c
c       find a box containing the rotated solution
c
        call mkrot(nx,ny,nz,q)
        call pbox(ntf,itnode,ibndry,itedge,vx,vy,icplt,
     +      iuvptr,ut,vt,sf,q,zratio,bmin,bmax,rp,nrl,rl,sxy)
c
        if(mpisw==1) call exbox(bmin,bmax,5_iknd)
c
        size=t(14)
        xs=t(15)
        ys=t(16)
        zs=t(17)
        scale=size/max(bmax(1)-bmin(1),bmax(2)-bmin(2))
        t(1)=xs-scale*(bmax(1)+bmin(1))/2.0e0_rknd
        t(2)=ys-scale*(bmax(2)+bmin(2))/2.0e0_rknd
        t(5)=zs-scale*(bmax(3)+bmin(3))/2.0e0_rknd
        t(3)=scale
c
c       parameters for legend plot
c
        if(ierrsw==1) then
            jp(1)=ip(1)
            call cdist(jp,t,e,kdist)
            jp(1)=ntf
            num=2*min(ncolor,11)
            if(mpisw==1) call exdist(kdist,num)
        endif
        do i=1,25
            tl(i)=t(i)
        enddo
        if(rmag<=1.0e0_rknd.or.jp(22)==0) then
            tl(2)=ys-scale*(bmax(4)+bmin(4))/2.0e0_rknd
            tl(5)=zs-scale*(bmax(5)+bmin(5))/2.0e0_rknd
        endif
        tl(12)=1.0e0_rknd
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pbox(ntf,itnode,ibndry,itedge,vx,vy,icplt,
     +      iuvptr,ut,vt,sf,q,zratio,bmin,bmax,rp,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3072) :: ibdy
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(2,*) :: iuvptr
            real(kind=rknd), dimension(*) :: vx,vy,ut,vt
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(5) :: bmin,bmax
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(3) :: x,y,zu,zv,cc,z
            real(kind=rknd), dimension(3072) :: xp,yp,up,vp
cy
            external sxy
            data index/1,2,3,2,3,1,3,1,2/
c
c       find min and max function values for cplot/vplot
c
c       initialize in case called with mpi on and ntf=0
c
        xx=(rp(16)+rp(18))/2.0e0_rknd
        yy=(rp(17)+rp(19))/2.0e0_rknd
        rr=q(1,1)*xx+q(2,1)*yy
        bmin(1)=rr
        bmax(1)=rr
        rr=q(1,2)*xx+q(2,2)*yy
        bmin(4)=rr
        bmax(4)=rr
        bmin(2)=rr
        bmax(2)=rr
        rr=q(1,3)*xx+q(2,3)*yy
        bmin(5)=rr
        bmax(5)=rr
        bmin(3)=rr
        bmax(3)=rr
c
        ifirst=1
        do i=1,ntf
            call tbdy(xp,yp,up,vp,ibdy,ntri,i,itnode,ibndry,itedge,
     +          vx,vy,sf,q,0_iknd,icplt,iuvptr,ut,vt,nrl,rl,sxy)
            do itri=1,3*ntri,3
                do j=1,3
                    m=j+itri-1
                    x(j)=xp(m)
                    y(j)=yp(m)
                    if(icplt==1) then
                        z(j)=up(m)*zratio
                    else
                        zu(j)=up(m)
                        zv(j)=vp(m)
                        z(j)=sqrt(up(m)**2+vp(m)**2)*zratio
                    endif
                    if(ifirst==1) then
                        rr=q(1,1)*x(j)+q(2,1)*y(j)
                        bmin(1)=rr
                        bmax(1)=rr
                        rr=q(1,2)*x(j)+q(2,2)*y(j)
                        bmin(4)=rr
                        bmax(4)=rr
                        rr=rr+q(3,2)*z(j)
                        bmin(2)=rr
                        bmax(2)=rr
                        rr=q(1,3)*x(j)+q(2,3)*y(j)
                        bmin(5)=rr
                        bmax(5)=rr
                        rr=rr+q(3,3)*z(j)
                        bmin(3)=rr
                        bmax(3)=rr
                        ifirst=0
                    else
                        rr=q(1,1)*x(j)+q(2,1)*y(j)
                        bmin(1)=min(rr,bmin(1))
                        bmax(1)=max(rr,bmax(1))
                        rr=q(1,2)*x(j)+q(2,2)*y(j)
                        bmin(4)=min(rr,bmin(4))
                        bmax(4)=max(rr,bmax(4))
                        rr=rr+q(3,2)*z(j)
                        bmin(2)=min(rr,bmin(2))
                        bmax(2)=max(rr,bmax(2))
                        rr=q(1,3)*x(j)+q(2,3)*y(j)
                        bmin(5)=min(rr,bmin(5))
                        bmax(5)=max(rr,bmax(5))
                        rr=rr+q(3,3)*z(j)
                        bmin(3)=min(rr,bmin(3))
                        bmax(3)=max(rr,bmax(3))
                    endif
                enddo
                if(icplt==1) cycle
c
c       check bari center
c
                do j=1,3
                    j2=index(2,j)
                    j3=index(3,j)
                    cc(j)=zu(j2)*zv(j3)-zu(j3)*zv(j2)
                enddo
                det=cc(1)+cc(2)+cc(3)
                if(det/=0.0e0_rknd) then
                    do j=1,3
                        cc(j)=cc(j)/det
                    enddo
                    if(max(cc(1),cc(2),cc(3))<=1.0e0_rknd.and.
     +                  min(cc(1),cc(2),cc(3))>=0.0e0_rknd) then
                        xx=cc(1)*x(1)+cc(2)*x(2)+cc(3)*x(3)
                        yy=cc(1)*y(1)+cc(2)*y(2)+cc(3)*y(3)
                        rr=q(1,2)*xx+q(2,2)*yy
                        bmin(2)=min(rr,bmin(2))
                        rr=q(1,3)*xx+q(2,3)*yy
                        bmin(3)=min(rr,bmin(3))
                     endif
                 endif
c
c       look on edges
c
                do j=1,3
                    j2=index(2,j)
                    j3=index(3,j)
                    u2=zu(j2)-zu(j3)
                    v2=zv(j2)-zv(j3)
                    aa=u2**2+v2**2
                    if(aa<=0.0e0_rknd) cycle
                    c2=-(u2*zu(j3)+v2*zv(j3))/aa
                    if(c2>=0.0e0_rknd.and.c2<=1.0e0_rknd) then
                        uu=zu(j3)+c2*u2
                        vv=zv(j3)+c2*v2
                        xx=x(j3)+c2*(x(j2)-x(j3))
                        yy=y(j3)+c2*(y(j2)-y(j3))
                        zz=sqrt(uu**2+vv**2)*zratio
                        rr=q(1,2)*xx+q(2,2)*yy+q(3,2)*zz
                        bmin(2)=min(rr,bmin(2))
                        rr=q(1,3)*xx+q(2,3)*yy+q(3,3)*zz
                        bmin(3)=min(rr,bmin(3))
                    endif
                enddo
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tribx3(c,len,bu,bv,ut,vt)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(3,*) :: c
            real(kind=rknd), dimension(3,7) :: c0
            real(kind=rknd), dimension(3) :: vt,ut
            real(kind=rknd), dimension(8) :: bu,bv
cy
c       compute intersection of triangle and box
c
c       compute baricentric coords of box
c
c       c1 + c2 + c3 =1
c       c1 * ut(1) + c2 * ut(2) +c3 * ut(3) =  bu
c       c1 * vt(1) + c2 * vt(2) +c3 * vt(3) =  bv
c
        x2=ut(2)-ut(1)
        y2=vt(2)-vt(1)
        x3=ut(3)-ut(1)
        y3=vt(3)-vt(1)
        det=x2*y3-x3*y2
        do j=1,4
            xr=bu(j)-ut(1)
            yr=bv(j)-vt(1)
            c(2,j)=(xr*y3-x3*yr)/det
            c(3,j)=(x2*yr-xr*y2)/det
            c(1,j)=1.0e0_rknd-c(2,j)-c(3,j)
        enddo
c
c       now compute the polygon inside the triangle
c
        len=4
        do i=1,3
            len0=len
            len=0
            do k=1,len0
               do j=1,3
                    c0(j,k)=c(j,k)
                enddo
            enddo
c
            do k=1,len0
                if(c0(i,k)>=0.0e0_rknd) then
                    len=len+1
                    do j=1,3
                        c(j,len)=c0(j,k)
                    enddo
                else
                    kbef=k-1
                    if(k==1) kbef=len0
                    kaft=k+1
                    if(k==len0) kaft=1
                    m=kbef
                    do mba=1,2
                        if(c0(i,m)>0.0e0_rknd) then
                            len=len+1
                            s=c0(i,m)/(c0(i,m)-c0(i,k))
                            do j=1,3
                                c(j,len)=c0(j,k)*s
     +                              +c0(j,m)*(1.0e0_rknd-s)
                            enddo
                        endif
                        m=kaft
                    enddo
                endif
            enddo
            if(len<=2) then
                len=0
                return
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tribx2(c,len,bu,bv,ut,vt)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(3,*) :: c
            real(kind=rknd), dimension(3,7) :: c0
            real(kind=rknd), dimension(3) :: vt,ut,at,a
            real(kind=rknd), dimension(8) :: bu,bv
            real(kind=rknd), dimension(4) :: f
cy
c       compute intersection of triangle and box
c
c       c1 + c2 + c3 = 1
c       c1 * ut(1) + c2 * ut(2) +c3 * ut(3) =  bu
c       c1 * vt(1) + c2 * vt(2) +c3 * vt(3) =  bv
c
c
        kmin=1
        kmid=2
        kmax=3
        d12=(ut(2)-ut(1))**2+(vt(2)-vt(1))**2
        d23=(ut(2)-ut(3))**2+(vt(2)-vt(3))**2
        d13=(ut(3)-ut(1))**2+(vt(3)-vt(1))**2
        if(d12>=max(d23,d13)) then
            kmin=1
            kmid=3
            kmax=2
        endif
        if(d23>=max(d12,d13)) then
            kmin=2
            kmid=1
            kmax=3
        endif
c
c       compute kernal of a-transpose
c
        at(1)=ut(kmax)*vt(kmin)-vt(kmax)*ut(kmin)
        at(2)=vt(kmax)-vt(kmin)
        at(3)=ut(kmin)-ut(kmax)
        dd=max(abs(at(1)),abs(at(2)),abs(at(3)))
        do j=1,3
            at(j)=at(j)/dd
        enddo
c
c       evaluate at * (1,bu,bv) at each corner of box
c
        do j=1,4
            f(j)=at(1)+at(2)*bu(j)+at(3)*bv(j)
            if(f(j)==0.0e0_rknd) f(j)=1.0e-7_rknd
        enddo
c
c       compute kernal of a
c
        au=(ut(1)+ut(2)+ut(3))/3.0e0_rknd
        av=(vt(1)+vt(2)+vt(3))/3.0e0_rknd
        qu=sqrt((ut(1)-au)**2+(ut(2)-au)**2+(ut(3)-au)**2)
        qv=sqrt((vt(1)-av)**2+(vt(2)-av)**2+(vt(3)-av)**2)
        tol=1.0e-2_rknd
        if(qv<tol*qu) then
             a(1)=ut(3)-ut(2)
             a(2)=ut(1)-ut(3)
             a(3)=ut(2)-ut(1)
        else
             a(1)=vt(3)-vt(2)
             a(2)=vt(1)-vt(3)
             a(3)=vt(2)-vt(1)
        endif
        if(a(kmid)==0.0e0_rknd) stop 7333
        dd=a(kmid)
        do j=1,3
            a(j)=a(j)/dd
        enddo
c
c       all these points are in the range of a
c
        x2=ut(kmax)-ut(kmin)
        y2=vt(kmax)-vt(kmin)
        len=0
        kbef=4
        do k=1,4
            if(f(kbef)*f(k)<0.0e0_rknd) then
                len=len+1
                s=f(k)/(f(k)-f(kbef))
                bbu=bu(kbef)*s+bu(k)*(1.0e0_rknd-s)
                bbv=bv(kbef)*s+bv(k)*(1.0e0_rknd-s)
c
c       solve 2 x 2 system based on kmax,kmin
c
                if(abs(x2)>abs(y2)) then
                    c(kmax,len)=(bbu-ut(kmin))/x2
                else
                    c(kmax,len)=(bbv-vt(kmin))/y2
                endif
                c(kmin,len)=1.0e0_rknd-c(kmax,len)
                c(kmid,len)=0.0e0_rknd
            endif
            kbef=k
        enddo
        if(len<=1) then
            len=0
            return
        endif
        if(len>2) stop 7434
c
c       now make a box using kernal of a
c
        do k=2,1,-1
            len=len+1
            do j=1,3
                c(j,len)=c(j,k)+a(j)
            enddo
        enddo
c
c       now compute the polygon inside the triangle
c
        do i=1,3
            len0=len
            len=0
            do k=1,len0
               do j=1,3
                    c0(j,k)=c(j,k)
                enddo
            enddo
c
            do k=1,len0
                if(c0(i,k)>=0.0e0_rknd) then
                    len=len+1
                    do j=1,3
                        c(j,len)=c0(j,k)
                    enddo
                else
                    kbef=k-1
                    if(k==1) kbef=len0
                    kaft=k+1
                    if(k==len0) kaft=1
                    m=kbef
                    do mba=1,2
                        if(c0(i,m)>0.0e0_rknd) then
                            len=len+1
                            s=c0(i,m)/(c0(i,m)-c0(i,k))
                            do j=1,3
                                c(j,len)=c0(j,k)*s
     +                              +c0(j,m)*(1.0e0_rknd-s)
                            enddo
                        endif
                        m=kaft
                    enddo
                endif
            enddo
            if(len<=2) then
                len=0
                return
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine gbx(wu,wv,gmin,gmax,tmin,tmax,eps,irank)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: wu,wv
            real(kind=rknd), dimension(3) :: rr,ang,tu,tv,cc
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c        compute min and max of vector function modulus on triangle
c
        pi2=3.141592653589793e0_rknd*2.0e0_rknd
c
c    check vertices
c
        do j=1,3
            tu(j)=wu(j)
            tv(j)=wv(j)
            rr(j)=sqrt(tu(j)**2+tv(j)**2)
        enddo
        gmax=rr(1)
        gmin=gmax
        tmin=pi2
        tmax=0.0e0_rknd
        do j=1,3
            gmax=max(gmax,rr(j))
            gmin=min(gmin,rr(j))
            ang(j)=0.0e0_rknd
            if(rr(j)>0.0e0_rknd) then
                arg=min(tu(j)/rr(j),1.0e0_rknd)
                arg=max(-1.0e0_rknd,arg)
                theta=acos(arg)
                if(tv(j)<0.0e0_rknd) theta=pi2-theta
                tmin=min(tmin,theta)
                tmax=max(tmax,theta)
                ang(j)=theta
            endif
        enddo
        if(gmax<=0.0e0_rknd) then
            tmin=0.0e0_rknd
            tmax=0.0e0_rknd
            return
        endif
        if(irank==1) then
            gmin=gmax
            tmin=tmax
            return
        endif
c
c       check bari center
c
        do j=1,3
            j2=index(2,j)
            j3=index(3,j)
            cc(j)=tu(j2)*tv(j3)-tu(j3)*tv(j2)
        enddo
        det=cc(1)+cc(2)+cc(3)
        if(det/=0.0e0_rknd) then
            do j=1,3
                cc(j)=cc(j)/det
            enddo
            if(max(cc(1),cc(2),cc(3))<=1.0e0_rknd+eps.and.
     +          min(cc(1),cc(2),cc(3))>-eps) then
                gmin=0.0e0_rknd
                tmin=0.0e0_rknd
                tmax=pi2
                return
            endif
        endif
c
c    look on edges
c
        umax=0.0e0_rknd
        do j=1,3
            j2=index(2,j)
            j3=index(3,j)
            u1=tu(j2)-tu(j3)
            v1=tv(j2)-tv(j3)
c
c    check for min radius
c
            a1=u1*u1+v1*v1
            if(a1>0.0e0_rknd) then
                c1=-(u1*tu(j3)+v1*tv(j3))/a1
                if(c1>=0.0e0_rknd.and.c1<=1.0e0_rknd) then
                    ut=tu(j3)+c1*u1
                    vt=tv(j3)+c1*v1
                    s=sqrt(ut*ut+vt*vt)
                    gmin=min(gmin,s)
                endif
            endif
c
c      check for crossing of positive x axis
c
            if(v1/=0.0e0_rknd) then
                c1=-tv(j3)/v1
                if(c1>=0.0e0_rknd.and.c1<=1.0e0_rknd)
     +              umax=max(umax,tu(j3)+c1*u1)
            endif
c
        enddo
        if(umax>eps*gmax) then
            do j=1,3
                if(tv(j)>=0.0e0_rknd) ang(j)=ang(j)+pi2
            enddo
            tmin=min(ang(1),ang(2),ang(3))
            tmax=max(ang(1),ang(2),ang(3))
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine trnk(irank,uu,vv,rmax,eps)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(3) :: uu,vv,ua,va
cy
c       compute rank of 3 x 3 matrix, if irank=3, compute inverse
c
        tol=max(1.0e-3_rknd,eps)
        au=(uu(1)+uu(2)+uu(3))/3.0e0_rknd
        av=(vv(1)+vv(2)+vv(3))/3.0e0_rknd
        do j=1,3
            ua(j)=(uu(j)-au)/rmax
            va(j)=(vv(j)-av)/rmax
        enddo
        qu=sqrt(ua(1)**2+ua(2)**2+ua(3)**2)
        qv=sqrt(va(1)**2+va(2)**2+va(3)**2)
        uv=abs(ua(1)*va(1)+ua(2)*va(2)+ua(3)*va(3))
        if(qu*qv>0.0e0_rknd) then
            dp=max(0.0e0_rknd,1.0e0_rknd-uv/(qu*qv))
        else
            dp=0.0e0_rknd
        endif
c
c       test for rank 1
c
        if(max(qu,qv)<tol) then
            irank=1
c
c       test for rank 3
c
        else if(min(qv,qu,dp)>eps) then
            irank=3
c
c       test for rank 2
c
        else if(qu<tol.and.qv>tol) then
            irank=2
        else if(qv<tol.and.qu>tol) then
            irank=2
        else if(dp<tol) then
            irank=2
c
c       default is rank 3
c
        else
            irank=3
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tinit(diam,jp,itnode,iclr,vx,vy,num,val)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(*) :: iclr
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), save, dimension(3,6) :: mcic
            integer(kind=iknd), dimension(5) :: num
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2) :: val
            real(kind=rknd), allocatable, dimension(:) :: hmin,hmax
cy
            data mcic/2,2,1,1,3,2,2,1,3,3,2,4,3,2,5,4,2,6/
            data index/1,2,3,2,3,1,3,1,2/
c
c       set colors for element quality, min angle, max angle
c
        ntf=jp(1)
        nvf=jp(2)
        inplsw=jp(9)
        mxcolr=jp(17)
c
        pi=3.141592653589793e0_rknd
        if(mxcolr>=3.and.mxcolr<8) then
            ic=mxcolr-2
        else
            ic=6
        endif
        ngood=0
        npoor=0
c
c       element quality
c
        if(inplsw==2) then
            qgood=sqrt(3.0e0_rknd)/2.0e0_rknd-1.0e-4_rknd
            qpoor=0.6e0_rknd+1.0e-4_rknd
            qmin=1.0e0_rknd
            qave=0.0e0_rknd
            do i=1,ntf
                r=abs(geom(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy))
                qmin=min(qmin,r)
                qave=qave+r
                iclr(i)=mcic(2,ic)
                if(r>=qgood) then
                    ngood=ngood+1
                    iclr(i)=mcic(1,ic)
                else if(r<=qpoor) then
                    npoor=npoor+1
                    iclr(i)=mcic(3,ic)
                endif
            enddo
c
c       max angle
c
        else if(inplsw==3) then
            agood=1.0e0_rknd/2.0e0_rknd+1.0e-4_rknd
            apoor=2.0e0_rknd/3.0e0_rknd-1.0e-4_rknd
            angmx=0.0e0_rknd
            amxave=0.0e0_rknd
            do i=1,ntf
                r=cangmx(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy)
                angmx=max(angmx,r)
                amxave=amxave+r
                iclr(i)=mcic(2,ic)
                if(r<=agood) then
                    ngood=ngood+1
                    iclr(i)=mcic(1,ic)
                else if(r>=apoor) then
                    npoor=npoor+1
                    iclr(i)=mcic(3,ic)
                endif
            enddo
            qmin=-180.0e0_rknd*angmx
            qave=180.0e0_rknd*amxave
c
c       min angle
c
        else if(inplsw==4) then
            bgood=acos(4.0e0_rknd/5.0e0_rknd)/pi-1.0e-4_rknd
            bpoor=acos(13.0e0_rknd/14.0e0_rknd)/pi+1.0e-4_rknd
            angmn=1.0e0_rknd
            amnave=0.0e0_rknd
            do i=1,ntf
                r=cangmn(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy)
                angmn=min(angmn,r)
                amnave=amnave+r
                iclr(i)=mcic(2,ic)
                if(r>=bgood) then
                    ngood=ngood+1
                    iclr(i)=mcic(1,ic)
                else if(r<=bpoor) then
                    npoor=npoor+1
                    iclr(i)=mcic(3,ic)
                endif
            enddo
            qmin=180.0e0_rknd*angmn
            qave=180.0e0_rknd*amnave
        else if(inplsw==5) then
c
c       grading
c
            allocate(hmin(nvf),hmax(nvf)) 
            do i=1,nvf
                hmin(i)=diam
                hmax(i)=0.0e0_rknd
            enddo
            do i=1,ntf
                do j=1,3                 
                    k2=itnode(index(2,j),i)
                    k3=itnode(index(3,j),i)
                    hh=sqrt((vx(k2)-vx(k3))**2+(vy(k2)-vy(k3))**2)
                    hmin(k2)=min(hmin(k2),hh)
                    hmax(k2)=max(hmax(k2),hh)
                    hmin(k3)=min(hmin(k3),hh)
                    hmax(k3)=max(hmax(k3),hh)
                enddo
            enddo
            do i=1,nvf
                hmax(i)=hmax(i)/hmin(i)
            enddo
            qmax=0.0e0_rknd
            qave=0.0e0_rknd
            qgood=2.0e0_rknd
            qpoor=3.0e0_rknd
            do i=1,ntf
                r=max(hmax(itnode(1,i)),hmax(itnode(2,i)),
     +              hmax(itnode(3,i)))
                qmax=max(qmax,r)
                qave=qave+r
                iclr(i)=mcic(2,ic)
                if(r<=qgood) then
                    iclr(i)=mcic(1,ic)
                    ngood=ngood+1
                else if(r>=qpoor) then
                    iclr(i)=mcic(3,ic)
                    npoor=npoor+1
                endif
            enddo
            qmin=qmax
            deallocate(hmin,hmax)
c
        endif
c
        num(1)=ngood
        num(2)=ntf-ngood-npoor
        num(3)=npoor
        num(4)=ntf
        num(5)=0
        val(1)=qmin
        val(2)=qave
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine clrmap(red,green,blue,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), save, dimension(7) :: ir,ig,ib
            real(kind=rknd), dimension(*) :: red,green,blue
cy
            data ir/1,1,1,0,0,0,1/
            data ig/0,0,1,1,1,0,0/
            data ib/1,0,0,0,1,1,1/
c
c       set up a color map
c
        ncolor=jp(5)
        icplt=jp(4)
        nshade=jp(16)
        mxcolr=jp(17)
        maplen=jp(18)
        gamma=0.7e0_rknd
        theta=1.0e0_rknd
c
c       background color (white)
c
        red(1)=1.0e0_rknd
        green(1)=1.0e0_rknd
        blue(1)=1.0e0_rknd
c
c       line-drawing color (black)
c
        red(2)=0.0e0_rknd
        green(2)=0.0e0_rknd
        blue(2)=0.0e0_rknd
c
        if(maplen<=2) return
c
        if(ncolor>=mxcolr-2) then
            jcolor=mxcolr-2
        else
            jcolor=ncolor
        endif
c
c       the primary set of colors
c
        red(3)=real(ir(7),rknd)
        green(3)=real(ig(7),rknd)
        blue(3)=real(ib(7),rknd)
        if(jcolor==1) go to 20
        if(icplt/=0) then
            h=5.0e0_rknd/real(jcolor-1,rknd)
        else
            h=6.0e0_rknd/real(jcolor,rknd)
        endif
        do ii=2,jcolor
            i=ii+2
            x=6.0e0_rknd-h*real(ii-1,rknd)
            k=1+int(x)
            dl=real(k,rknd)-x
            dr=1.0e0_rknd-dl
            red(i)=dl*real(ir(k),rknd)+dr*real(ir(k+1),rknd)
            red(i)=max(0.0e0_rknd,red(i))**gamma
            red(i)=min(1.0e0_rknd,red(i))
            green(i)=dl*real(ig(k),rknd)+dr*real(ig(k+1),rknd)
            green(i)=max(0.0e0_rknd,green(i))**gamma
            green(i)=min(1.0e0_rknd,green(i))
            blue(i)=dl*real(ib(k),rknd)+dr*real(ib(k+1),rknd)
            blue(i)=max(0.0e0_rknd,blue(i))**gamma
            blue(i)=min(1.0e0_rknd,blue(i))
        enddo
c
c       shading
c
   20   if(nshade==0) return
        if(icplt/=0) then
            bmax=0.5e0_rknd/real(nshade,rknd)
            wmax=0.5e0_rknd/real(nshade,rknd)
        else
            bmax=0.45e0_rknd/real(nshade,rknd)
            wmax=0.75e0_rknd/real(nshade,rknd)
        endif
        do j=1,nshade
            jplus=j*ncolor+2
            jminus=jplus+nshade*ncolor
            fb=(1.0e0_rknd-real(j,rknd)*bmax)**theta
            fw=(1.0e0_rknd-real(j,rknd)*wmax)**theta
            w=1.0e0_rknd-fw
            do i=1,ncolor
                k=i+jplus
                red(k)=red(i+2)*fw+w
                red(k)=max(red(k),0.0e0_rknd)
                red(k)=min(red(k),1.0e0_rknd)
                green(k)=green(i+2)*fw+w
                green(k)=max(green(k),0.0e0_rknd)
                green(k)=min(green(k),1.0e0_rknd)
                blue(k)=blue(i+2)*fw+w
                blue(k)=max(blue(k),0.0e0_rknd)
                blue(k)=min(blue(k),1.0e0_rknd)
                k=i+jminus
                red(k)=red(i+2)*fb
                red(k)=max(red(k),0.0e0_rknd)
                red(k)=min(red(k),1.0e0_rknd)
                green(k)=green(i+2)*fb
                green(k)=max(green(k),0.0e0_rknd)
                green(k)=min(green(k),1.0e0_rknd)
                blue(k)=blue(i+2)*fb
                blue(k)=max(blue(k),0.0e0_rknd)
                blue(k)=min(blue(k),1.0e0_rknd)
            enddo
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function ccolor(icolor,ishade,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
cy
c       compute the color index
c
        ncolor=jp(5)
        nshade=jp(16)
        mxcolr=jp(17)
        if(icolor<=0.or.icolor>ncolor
     +      .or.abs(ishade)>nshade) then
            ccolor=1
        else if(ishade==0) then
            ccolor=icolor+2-((icolor-1)/(mxcolr-1))*(mxcolr-1)
            if(ccolor>mxcolr) ccolor=1
        else
            if(ishade>0) then
                ccolor=icolor+2+ncolor*ishade
            else
                ccolor=icolor+2+ncolor*(nshade-ishade)
            endif
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine incirc(x1,y1,x2,y2,x3,y3,xc,yc,r)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
cy
c       compute center of inscribed circle
c
        h1=sqrt((x2-x3)**2+(y2-y3)**2)
        h2=sqrt((x3-x1)**2+(y3-y1)**2)
        h3=sqrt((x1-x2)**2+(y1-y2)**2)
        h=(h1+h2+h3)/2.0e0_rknd
        s1=x2+((h-h2)/h1)*(x3-x2)
        t1=y2+((h-h2)/h1)*(y3-y2)
        s2=x3+((h-h3)/h2)*(x1-x3)
        t2=y3+((h-h3)/h2)*(y1-y3)
        s3=x1+((h-h1)/h3)*(x2-x1)
        t3=y1+((h-h1)/h3)*(y2-y1)
        call centre(s1,t1,s2,t2,s3,t3,xc,yc)
        r=sqrt((xc-s1)**2+(yc-t1)**2)
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine arc(x1,y1,x2,y2,xc,yc,theta1,theta2,r,alen)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
cy
c       compute the parametric representation of the arc of
c       the circle passing through (x1,y1) and (x2,y2) with
c       center at (xc,yc).
c
        pi=3.141592653589793e0_rknd
        v1=x1-xc
        w1=y1-yc
        r1=sqrt(v1**2+w1**2)
        v1=v1/r1
        w1=w1/r1
c
        v2=x2-xc
        w2=y2-yc
        r2=sqrt(v2**2+w2**2)
        v2=v2/r2
        w2=w2/r2
c
        vm=(v1+v2)/2.0e0_rknd
        wm=(w1+w2)/2.0e0_rknd
        dd=sqrt(vm**2+wm**2)
        vm=vm/dd
        wm=wm/dd
c
        r=sqrt(r1*r2)
        theta=max(-1.0e0_rknd,vm)
        theta=min(1.0e0_rknd,theta)
        theta=acos(theta)
        if(wm<0.0e0_rknd) theta=-theta
c
        dtheta=min(1.0e0_rknd,dd)
        dtheta=acos(dtheta)
        if(v1*wm-w1*vm>0.0e0_rknd) dtheta=-dtheta
        theta1=(theta+dtheta)/pi
        theta2=(theta-dtheta)/pi
        alen=abs(dtheta*r*2.0e0_rknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tbdy(xp,yp,up,vp,ibdy,ntri,it,itnode,ibndry,itedge,
     +      vx,vy,sf,q,i3d,icplt,iuvptr,ut,vt,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ibdy
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3) :: iadj,icurv
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(2,*) :: iuvptr
            integer(kind=iknd), dimension(3) :: iords,jords
            integer(kind=iknd), dimension(8,1) :: ktdof
            real(kind=rknd), dimension(*) :: vx,vy,ut,vt,xp,yp,up
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(21,21) :: c1,c2,c3,b1,b2,b3,x,y,u
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(3) :: xr,dr,rad,theta1,theta2,c
            real(kind=rknd), dimension(*) :: vp
            real(kind=rknd), dimension(100) :: gx,gy,gv,tu,tv
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(21,21) :: v
            real(kind=rknd), dimension(2,15) :: values
            common /pltmg1/ic(3,363),jc(12)
cy
            external sxy
            data index/1,2,3,2,3,1,3,1,2/
            data ktdof/0,0,0,0,0,0,0,0/
c
c       compute parameterization of triangle it in terms of
c       baricentric coordinates
c
        pi=3.141592653589793e0_rknd
        irefn=1
        do j=1,3
            if(itedge(j,it)>0) then
                k=itedge(j,it)/4
                icurv(j)=0
                iadj(j)=0
                if(itnode(5,it)/=itnode(5,k)) iadj(j)=2
                if(itnode(4,it)/=itnode(4,k)) iadj(j)=iadj(j)+3
            else
                iadj(j)=1
                k=-itedge(j,it)
                if(ibndry(4,k)==4)  iadj(j)=5
                if(ibndry(4,k)==3)  iadj(j)=3
                if(ibndry(3,k)==0) then
                    icurv(j)=0
                else if(ibndry(3,k)>0) then
                    icurv(j)=k
                    iv1=itnode(index(2,j),it)
                    iv2=itnode(index(3,j),it)
                    call arc(vx(iv1),vy(iv1),vx(iv2),vy(iv2),
     +                  sf(1,k),sf(2,k),theta1(j),theta2(j),rad(j),
     1                  alen)
                    aa=abs(theta2(j)-theta1(j))*32.0e0_rknd
                    mm=min(int(aa+0.5e0_rknd),8)
                    irefn=max(irefn,mm)
                else
                    icurv(j)=ibndry(3,k)
                    if(itnode(index(2,j),it)==ibndry(1,k)) then
                        theta1(j)=sf(1,k)
                        theta2(j)=sf(2,k)
                    else
                        theta1(j)=sf(2,k)
                        theta2(j)=sf(1,k)
                    endif
                    irefn=max(irefn,8)
                endif
            endif
        enddo
c
c       make sure there is adaquate refinment, and that dofs are verts
c       get function values
c
        if(icplt>=0) then
            ktdof(8,1)=iuvptr(2,it)
            call locord(1_iknd,ndof,jord,jords,ktdof)
            iord=max(jord,jords(1),jords(2),jords(3))
            iords(1)=iord
            iords(2)=iord
            iords(3)=iord
            call p2q2d(ut(iuvptr(1,it)),tu,jord,iord,jords,iords)
            if(icplt==0) then
                call p2q2d(vt(iuvptr(1,it)),tv,jord,iord,jords,iords)
            endif
            irefn=max(2*iord,irefn)
            irefn=((irefn+iord-1)/iord)*iord
        else
            iord=1
        endif
        ndof=(iord+1)*(iord+2)/2
c
c       set up initial baricentric coodinates
c
        do k=1,irefn+1
            do j=1,irefn+2-k
                c2(k,j)=real(k-1,rknd)/real(irefn,rknd)
                c3(k,j)=real(j-1,rknd)/real(irefn,rknd)
                c1(k,j)=1.0e0_rknd-c2(k,j)-c3(k,j)
                b1(k,j)=c1(k,j)
                b2(k,j)=c2(k,j)
                b3(k,j)=c3(k,j)
                x(k,j)=0.0e0_rknd
                y(k,j)=0.0e0_rknd
                u(k,j)=0.0e0_rknd
                v(k,j)=0.0e0_rknd
            enddo
        enddo
c
c       simple case
c
        if(irefn==1) then
            x(1,1)=vx(itnode(1,it))
            x(2,1)=vx(itnode(2,it))
            x(1,2)=vx(itnode(3,it))
            y(1,1)=vy(itnode(1,it))
            y(2,1)=vy(itnode(2,it))
            y(1,2)=vy(itnode(3,it))
            if(icplt>=0) then
                u(1,1)=tu(1)
                u(2,1)=tu(2)
                u(1,2)=tu(3)
            endif
            if(icplt==0) then
                v(1,1)=tv(1)
                v(2,1)=tv(2)
                v(1,2)=tv(3)
            endif
            go to 30
        endif
c
c       modify barycentric coordinates for curved edges
c
        do j=1,3
            if(icurv(j)==0) cycle
            kt=icurv(j)
            itag=-icurv(j)
            iv1=itnode(index(2,j),it)
            iv2=itnode(index(3,j),it)
            iv3=itnode(j,it)
            dt=(theta2(j)-theta1(j))/real(irefn,rknd)
            x1=vx(iv1)-vx(iv3)
            x2=vx(iv2)-vx(iv3)
            y1=vy(iv1)-vy(iv3)
            y2=vy(iv2)-vy(iv3)
            det=x1*y2-y1*x2
            do m=2,irefn
                if(kt>0) then
                    tt=(theta1(j)+dt*real(m-1,rknd))*pi
                    xx=sf(1,kt)+rad(j)*cos(tt)-vx(iv3)
                    yy=sf(2,kt)+rad(j)*sin(tt)-vy(iv3)
                else
                    tt=(theta1(j)+dt*real(m-1,rknd))
                    do mm=1,2+nrl
                        values(1,mm)=0.0e0_rknd
                        values(2,mm)=0.0e0_rknd
                    enddo
                    call sxy(rl,tt,itag,values)
                    xx=values(1,1)-vx(iv3)
                    yy=values(2,1)-vy(iv3)
                endif
                mm=irefn+2-m
                if(j==1) then
                    c2(mm,m)=(xx*y2-yy*x2)/det
                    c3(mm,m)=(x1*yy-y1*xx)/det
                    c1(mm,m)=1.0e0_rknd-c2(mm,m)-c3(mm,m)
                else if(j==2) then
                    c3(1,mm)=(xx*y2-yy*x2)/det
                    c1(1,mm)=(x1*yy-y1*xx)/det
                    c2(1,mm)=1.0e0_rknd-c3(1,mm)-c1(1,mm)
                else
                    c1(m,1)=(xx*y2-yy*x2)/det
                    c2(m,1)=(x1*yy-y1*xx)/det
                    c3(m,1)=1.0e0_rknd-c1(m,1)-c2(m,1)
                endif
            enddo
        enddo
c
c       smoothing
c
        if(iord==1) then
            itmax=100
            tol=1.0e-2_rknd
            do i=1,itmax
                cc=0.0e0_rknd
                do k=2,irefn-1
                    do j=2,irefn+1-k
                        cc2=(c2(k,j-1)+c2(k,j+1)+c2(k+1,j)+
     +                      c2(k-1,j)+c2(k+1,j-1)+
     1                      c2(k-1,j+1))/6.0e0_rknd
                        cc3=(c3(k,j-1)+c3(k,j+1)+c3(k+1,j)+
     +                      c3(k-1,j)+c3(k+1,j-1)+
     1                      c3(k-1,j+1))/6.0e0_rknd
                        cc=max(cc,abs(cc2-c2(k,j)),abs(cc3-c3(k,j)))
                        c2(k,j)=cc2
                        c3(k,j)=cc3
                        c1(k,j)=1.0e0_rknd-cc2-cc3
                    enddo
                enddo
                if(cc<=tol) exit
            enddo
            iv1=itnode(1,it)
            iv2=itnode(2,it)
            iv3=itnode(3,it)
            do k=1,irefn+1
                do j=1,irefn+2-k
                    x(k,j)=c1(k,j)*vx(iv1)+c2(k,j)*vx(iv2)
     +                  +c3(k,j)*vx(iv3)
                    y(k,j)=c1(k,j)*vy(iv1)+c2(k,j)*vy(iv2)
     +                  +c3(k,j)*vy(iv3)
                    if(icplt>=0) u(k,j)=c1(k,j)*tu(1)+
     +                  c2(k,j)*tu(2)+c3(k,j)*tu(3)
                    if(icplt==0) v(k,j)=c1(k,j)*tv(1)+
     +                  c2(k,j)*tv(2)+c3(k,j)*tv(3)
                enddo
            enddo
c
c       isoparametric map for quadratics
c
        else
            gx(1)=vx(itnode(1,it))
            gy(1)=vy(itnode(1,it))
            gx(2)=vx(itnode(2,it))
            gy(2)=vy(itnode(2,it))
            gx(3)=vx(itnode(3,it))
            gy(3)=vy(itnode(3,it))
c
c       isoparametric map
c
            inc=irefn/iord
            do k=jc(iord)+3,jc(iord+1)-1
                m=k-jc(iord)+1
                j2=ic(2,k)*inc+1
                j3=ic(3,k)*inc+1
                gx(m)=c1(j2,j3)*gx(1)+c2(j2,j3)*gx(2)+c3(j2,j3)*gx(3)
                gy(m)=c1(j2,j3)*gy(1)+c2(j2,j3)*gy(2)+c3(j2,j3)*gy(3)
            enddo
            do k=1,irefn+1
                do j=1,irefn+2-k
                    c(1)=b1(k,j)
                    c(2)=b2(k,j)
                    c(3)=b3(k,j)
                    call beval1(c,gv,iord,iords)
                    x(k,j)=0.0e0_rknd
                    y(k,j)=0.0e0_rknd
                    u(k,j)=0.0e0_rknd
                    v(k,j)=0.0e0_rknd
                    do m=1,ndof
                       x(k,j)=x(k,j)+gv(m)*gx(m)
                       y(k,j)=y(k,j)+gv(m)*gy(m)
                       if(icplt>=0) u(k,j)=u(k,j)+gv(m)*tu(m)
                       if(icplt==0) v(k,j)=v(k,j)+gv(m)*tv(m)
                    enddo
                enddo
            enddo
        endif
c
c       do orientation
c
        if(i3d==0) go to 30
        do j=1,3
            xr(j)=q(1,1)*vx(itnode(j,it))+q(2,1)*vy(itnode(j,it))
        enddo
        dr(1)=xr(3)-xr(2)
        dr(2)=xr(1)-xr(3)
        dr(3)=xr(2)-xr(1)
        iback=1
        if(dr(2)>dr(iback)) iback=2
        if(dr(3)>dr(iback)) iback=3
        imid=index(2,iback)
        ifront=index(3,iback)
        if(dr(ifront)>dr(imid)) imid=ifront
        ifront=6-iback-imid
c
c       swapping
c
        jmid=2
        if(iback==2) then
            do j=1,irefn
                jj=irefn+2-j
                do k=1,jj/2
                    xx=x(k,j)
                    x(k,j)=x(jj+1-k,j)
                    x(jj+1-k,j)=xx
                    yy=y(k,j)
                    y(k,j)=y(jj+1-k,j)
                    y(jj+1-k,j)=yy
                    uu=u(k,j)
                    u(k,j)=u(jj+1-k,j)
                    u(jj+1-k,j)=uu
                    vv=v(k,j)
                    v(k,j)=v(jj+1-k,j)
                    v(jj+1-k,j)=vv
                enddo
            enddo
            ii=iadj(1)
            iadj(1)=iadj(2)
            iadj(2)=ii
            jmid=1
        else if(iback==3) then
            do k=1,irefn
                kk=irefn+2-k
                do j=1,kk/2
                    xx=x(k,j)
                    x(k,j)=x(k,kk+1-j)
                    x(k,kk+1-j)=xx
                    yy=y(k,j)
                    y(k,j)=y(k,kk+1-j)
                    y(k,kk+1-j)=yy
                    uu=u(k,j)
                    u(k,j)=u(k,kk+1-j)
                    u(k,kk+1-j)=uu
                    vv=v(k,j)
                    v(k,j)=v(k,kk+1-j)
                    v(k,kk+1-j)=vv
                enddo
            enddo
            ii=iadj(1)
            iadj(1)=iadj(3)
            iadj(3)=ii
        endif
        if(jmid/=imid) then
            do k=2,irefn+1
                do j=1,k/2
                    xx=x(k+1-j,j)
                    x(k+1-j,j)=x(j,k+1-j)
                    x(j,k+1-j)=xx
                    yy=y(k+1-j,j)
                    y(k+1-j,j)=y(j,k+1-j)
                    y(j,k+1-j)=yy
                    uu=u(k+1-j,j)
                    u(k+1-j,j)=u(j,k+1-j)
                    u(j,k+1-j)=uu
                    vv=v(k+1-j,j)
                    v(k+1-j,j)=v(j,k+1-j)
                    v(j,k+1-j)=vv
                enddo
            enddo
            ii=iadj(2)
            iadj(2)=iadj(3)
            iadj(3)=ii
        endif
c
c       now make triangles
c
   30   k=0
        do j=1,irefn
            do i=1,irefn+1-j
                xp(k+1)=x(i,j)
                yp(k+1)=y(i,j)
                up(k+1)=u(i,j)
                vp(k+1)=v(i,j)
                xp(k+2)=x(i+1,j)
                yp(k+2)=y(i+1,j)
                up(k+2)=u(i+1,j)
                vp(k+2)=v(i+1,j)
                xp(k+3)=x(i,j+1)
                yp(k+3)=y(i,j+1)
                up(k+3)=u(i,j+1)
                vp(k+3)=v(i,j+1)
                ibdy(k+1)=-1
                ibdy(k+2)=-1
                ibdy(k+3)=-1
                if(j==1) ibdy(k+3)=iadj(3)
                if(i==1) ibdy(k+2)=iadj(2)
                if(i+j==irefn+1) ibdy(k+1)=iadj(1)
                k=k+3
                if(i+j==irefn+1) cycle
                xp(k+1)=x(i+1,j)
                yp(k+1)=y(i+1,j)
                up(k+1)=u(i+1,j)
                vp(k+1)=v(i+1,j)
                xp(k+2)=x(i+1,j+1)
                yp(k+2)=y(i+1,j+1)
                up(k+2)=u(i+1,j+1)
                vp(k+2)=v(i+1,j+1)
                xp(k+3)=x(i,j+1)
                yp(k+3)=y(i,j+1)
                up(k+3)=u(i,j+1)
                vp(k+3)=v(i,j+1)
                ibdy(k+1)=-1
                ibdy(k+2)=-1
                ibdy(k+3)=-1
                k=k+3
            enddo
        enddo
        ntri=irefn**2
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function tblock(itnode,it,iside,vx,vy,q,eps)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd) :: tblock
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(3,3) :: q
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       test edge iside relative to the viewing direction
c       this routine assume that knots are ordered such that geom > 0
c
        j2=index(2,iside)
        j3=index(3,iside)
        c=vx(itnode(j2,it))-vx(itnode(j3,it))
        s=vy(itnode(j2,it))-vy(itnode(j3,it))
        qq=(c*q(1,1)+s*q(2,1))/sqrt(c**2+s**2)
        tblock=0
        if(qq>eps) tblock=1
        if(qq<-eps) tblock=-1
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine bblock(ntf,itnode,itedge,ilen,list,vx,vy,q,eps)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(*) :: list
            integer(kind=iknd), dimension(2,3*ilen) :: tlist
            integer(kind=iknd) :: tblock,endin,endout
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(ilen+ntf+1) :: cen
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       compute boundary types (ilen>=ntf)
c
        llen=4*ilen+1
c
        eps1=max(1.0e-4_rknd,eps*8.0e0_rknd)
c
c       make a list of triangles with boundary edges
c
        istrt=llen+1
        endin=0
        do i=1,ntf
            kin=0
            kout=0
            do j=1,3
                if(itedge(j,i)>0) cycle
                ity=tblock(itnode,i,j,vx,vy,q,eps1)
                if(ity==0) cycle
                if(ity==1) then
                    if(kin==0) then
                        endin=endin+1
                        list(endin)=j+4*i
                        kin=j
                    else
                        list(endin)=6-j-kin+4*i
                    endif
                else
                    if(kout==0) then
                        istrt=istrt-1
                        list(istrt)=j+4*i
                        kout=j
                    else
                        list(istrt)=6-j-kout+4*i
                    endif
                endif
            enddo
        enddo
c
c       out of space
c
        if(istrt<=endin) stop 7760
        do i=istrt,llen
            list(endin+i-istrt+1)=list(i)
        enddo
        endout=endin+llen-istrt+1
c
c       sort edges
c
       hmax=0.0e0_rknd
       do ic=1,2
            if(ic==1) then
                iptr=1
                kl=endin
            else
                iptr=endin+1
                kl=endout-endin
            endif
            do m=1,kl
                i=m+iptr-1
                it=list(i)/4
                iedge=list(i)-4*it
                j1=index(2,iedge)
                j2=index(3,iedge)
                x1i=q(1,1)*vx(itnode(j1,it))+q(2,1)*vy(itnode(j1,it))
                x2i=q(1,1)*vx(itnode(j2,it))+q(2,1)*vy(itnode(j2,it))
                cen(i)=(x1i+x2i)/2.0e0_rknd
                hmax=max(hmax,abs(x2i-x1i))
            enddo
            l2=kl/2
            do i=l2,1,-1
                call mkheap(i,kl,cen(iptr),list(iptr))
            enddo
            do i=kl,1,-1
                i1=list(iptr)
                list(iptr)=list(iptr+i-1)
                list(iptr+i-1)=i1
                c1=cen(iptr)
                cen(iptr)=cen(iptr+i-1)
                cen(iptr+i-1)=c1
                call mkheap(1_iknd,i-1_iknd,cen(iptr),list(iptr))
            enddo
        enddo
c
c       now make list of triangle pairs that interfere
c
        jstrt=1
        num=0
        do ii=endin+1,endout
            it=list(ii)/4
            iedge=list(ii)-4*it
            j1=index(2,iedge)
            j2=index(3,iedge)
            x1i=q(1,1)*vx(itnode(j1,it))+q(2,1)*vy(itnode(j1,it))
            x2i=q(1,1)*vx(itnode(j2,it))+q(2,1)*vy(itnode(j2,it))
            y1i=q(2,1)*vx(itnode(j1,it))-q(1,1)*vy(itnode(j1,it))
            y2i=q(2,1)*vx(itnode(j2,it))-q(1,1)*vy(itnode(j2,it))
            ximax=max(x1i,x2i)
            yimax=max(y1i,y2i)
            ximin=min(x1i,x2i)
            yimin=min(y1i,y2i)
            epsi=eps*(yimax-yimin+ximax-ximin)
c
            istrt=jstrt
            do jj=istrt,endin
c
c       simple tests to cut down compares
c
                if(cen(jj)+hmax<=cen(ii)) then
                    jstrt=jj
                    cycle
                endif
                if(ximin>=cen(jj)+hmax/2.0e0_rknd) cycle
                if(ximax<=cen(jj)-hmax/2.0e0_rknd) exit
c
                jt=list(jj)/4
                if(it==jt) cycle
                jedge=list(jj)-4*jt
                j1=index(2,jedge)
                j2=index(3,jedge)
                x1j=q(1,1)*vx(itnode(j1,jt))+q(2,1)*vy(itnode(j1,jt))
                x2j=q(1,1)*vx(itnode(j2,jt))+q(2,1)*vy(itnode(j2,jt))
                y1j=q(2,1)*vx(itnode(j1,jt))-q(1,1)*vy(itnode(j1,jt))
                y2j=q(2,1)*vx(itnode(j2,jt))-q(1,1)*vy(itnode(j2,jt))
                xjmax=max(x1j,x2j)
                xjmin=min(x1j,x2j)
                yjmax=max(y1j,y2j)
                yjmin=min(y1j,y2j)
                epsj=eps*(yjmax-yjmin+xjmax-xjmin)+epsi
c
c       simple tests to disregard this element
c
c*              if(yimin+epsj>=yjmax) cycle
                if(ximin+epsj>=xjmax) cycle
                if(xjmin+epsj>=ximax) cycle
c
                xx=(max(ximin,xjmin)+min(ximax,xjmax))/2.0e0_rknd
                yi=(y1i*(x2i-xx)+y2i*(xx-x1i))/(x2i-x1i)
                yj=(y1j*(x2j-xx)+y2j*(xx-x1j))/(x2j-x1j)
                if(yi-8.0e0_rknd*eps>=yj) cycle
c
c       this takes care of very special cases
c
                if(abs(yi-yj)<=8.0e0_rknd*eps) then
                    kout=0
                    do k=1,3
                        if(itedge(k,it)>0) cycle
                        ity=tblock(itnode,it,k,vx,vy,q,eps1)
                        if(ity==-1) kout=kout+1
                    enddo
                    if(kout==2) cycle
                    kin=0
                    do k=1,3
                        if(itedge(k,jt)>0) cycle
                        jty=tblock(itnode,jt,k,vx,vy,q,eps1)
                        if(jty==1) kin=kin+1
                    enddo
                    if(kin==2) cycle
                endif
c
c       we have found a conflicting pair
c
                num=num+1
                if(num>3*ilen) stop 7761
                tlist(1,num)=it
                tlist(2,num)=jt
c
            enddo
        enddo
c
c       make final list
c
        do i=1,ntf+1
            list(i)=0
        enddo
        if(num<=0) return
c
        do i=1,num
            j=tlist(1,i)
            list(j+1)=list(j+1)+1
        enddo
c
        list(1)=ntf+2
        do i=2,ntf+1
            list(i)=list(i)+list(i-1)
        enddo
        if(list(ntf+1)>llen+1) stop 7762
c
        do i=1,num
            j=tlist(1,i)
            k=list(j)
            list(j)=k+1
            list(k)=tlist(2,i)
        enddo
c
        do i=ntf+1,2,-1
            list(i)=list(i-1)
        enddo
        list(1)=ntf+2
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mkheap(i,llen,d,list)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: list
            real(kind=rknd), dimension(*) :: d
cy
c       this routine makes a heap with root at vertex i, assuming its
c       sons are already roots of heaps
c
        k=i
   10   kson=2*k
        if(kson>llen) return
        if(kson<llen) then
            if(d(kson+1)>d(kson)) kson=kson+1
        endif
        if(d(k)>=d(kson)) return
        ktemp=list(k)
        list(k)=list(kson)
        list(kson)=ktemp
        dtemp=d(k)
        d(k)=d(kson)
        d(kson)=dtemp
        k=kson
        go to 10
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine legnd0(t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(6) :: x,y,z
            real(kind=rknd), dimension(25) :: t,tt
            real(kind=rknd), dimension(3,3) :: q
cy
c       helps locating current window (draw boundary in small window)
c
        call linit(tt,q)
        zshift=tt(5)
        scale=tt(3)
        size=tt(14)
        dd=(scale+size)/4.0e0_rknd
        x0=tt(15)-dd
        x1=tt(15)+dd
        y0=tt(16)-dd
        y1=tt(16)+dd
c
c       mark magnified area
c
        do i=1,6
            z(i)=zshift
        enddo
        if(t(12)>1.0e0_rknd) then
            xl=max(x0,t(8))
            xr=min(x1,t(9))
            yb=max(y0,t(10))
            yt=min(y1,t(11))
c
c           mark the box in the window
c
            x(1)=(xl+xr)/2.0e0_rknd
            x(2)=x(1)
            y(1)=y0
            y(2)=yb
            call pline(x,y,z,2_iknd,2_iknd)
            y(1)=yt
            y(2)=y1
            call pline(x,y,z,2_iknd,2_iknd)
            x(1)=x0
            x(2)=xl
            y(1)=(yb+yt)/2.0e0_rknd
            y(2)=y(1)
            call pline(x,y,z,2_iknd,2_iknd)
            x(1)=xr
            x(2)=x1
            call pline(x,y,z,2_iknd,2_iknd)
            x(1)=xl
            y(1)=yb
            x(2)=xr
            y(2)=y(1)
            x(3)=x(2)
            y(3)=yt
            x(4)=x(1)
            y(4)=y(3)
            x(5)=x(1)
            y(5)=y(1)
            call pline(x,y,z,5_iknd,2_iknd)
        endif
c
        x(1)=x0
        y(1)=y0
        x(2)=x1
        y(2)=y(1)
        x(3)=x(2)
        y(3)=y1
        x(4)=x(1)
        y(4)=y(3)
        x(5)=x(1)
        y(5)=y(1)
        call pline(x,y,z,5_iknd,2_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine linit(t,q)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
cy
c
c       initial for legends and graphs
c
        size=0.9e0_rknd
        do i=1,25
            t(i)=0.0e0_rknd
        enddo
        t(3)=1.0e0_rknd
        t(5)=0.5e0_rknd
        t(7)=1.0e1_rknd*epsilon(1.0e0_rknd)
        t(12)=1.0e0_rknd
        t(14)=size
        t(15)=0.5e0_rknd
        t(16)=0.5e0_rknd
        t(17)=0.5e0_rknd
        do i=1,3
            do j=1,3
                q(i,j)=0.0e0_rknd
            enddo
            q(i,i)=1.0e0_rknd
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine zoombx(rp,t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(25) :: t
cy
c       compute the zoom-in window
c
        size=t(14)
        xs=t(15)
        ys=t(16)
        rmag=max(1.0e0_rknd,rp(8))
        cenx=max(0.0e0_rknd,rp(9))
        cenx=min(1.0e0_rknd,cenx)
        ceny=max(0.0e0_rknd,rp(10))
        ceny=min(1.0e0_rknd,ceny)
        h=1.0e0_rknd/(2.0e0_rknd*rmag)
        hx=xs-size/2.0e0_rknd
        hy=ys-size/2.0e0_rknd
        t(8)=size*(cenx-h)+hx
        t(9)=size*(cenx+h)+hx
        t(10)=size*(ceny-h)+hy
        t(11)=size*(ceny+h)+hy
        t(12)=rmag
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mkrot(nx,ny,nz,q)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(3) :: d
cy
c       compute rotation matrix
c
        d(1)=real(nx,rknd)
        d(2)=real(ny,rknd)
        d(3)=real(nz,rknd)
        do i=1,3
            do j=1,3
                q(j,i)=0.0e0_rknd
            enddo
            q(i,i)=1.0e0_rknd
        enddo
        dl=sqrt(d(1)*d(1)+d(2)*d(2)+d(3)*d(3))
        if(dl>0.0e0_rknd) then
            do i=1,3
                q(i,3)=d(i)/dl
            enddo
        endif
        dl=sqrt(q(1,3)*q(1,3)+q(2,3)*q(2,3))
        if(dl>0.0e0_rknd) then
            q(1,1)=-q(2,3)/dl
            q(2,1)=q(1,3)/dl
            q(1,2)=-q(2,1)*q(3,3)
            q(2,2)=q(1,1)*q(3,3)
            q(3,2)=dl
        else
            if(q(3,3)<0.0e0_rknd) q(1,1)=-q(1,1)
        endif
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine legnd1(jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            real(kind=rknd), dimension(4) :: x,y,z
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(25) :: t
            character(len=80) :: ichr
cy
        call linit(t,q)
        size=t(14)
        zshift=t(5)
        xs=t(15)
        ys=t(16)
c
        ncolor=jp(5)
        xl=xs-size/2.0e0_rknd
        xr=xs+size/2.0e0_rknd
        yb=ys-size/2.0e0_rknd
        yt=ys+size/2.0e0_rknd
        s3=sqrt(3.0e0_rknd)/2.0e0_rknd
c
c       compute ncol and nrow
c
        s=sqrt(real(ncolor,rknd)/3.0e0_rknd)
        is=int(s)
        if(s-real(is,rknd)>1.0e-3_rknd) is=is+1
        ncol=max(is,2)
        nrow=ncolor/ncol
        if(nrow*ncol<ncolor) nrow=nrow+1
        nrow=max(nrow,1)
        dx=(xr-xl)/real(ncol,rknd)
        dy=(yt-yb)/real(nrow,rknd)
        if(dx>3.0e0_rknd*dy) dx=3.0e0_rknd*dy
        if(dx<3.0e0_rknd*dy) dy=dx/3.0e0_rknd
c
c       the main loop
c
        icolor=0
        do nr=1,nrow
            do nc=1,ncol
                icolor=icolor+1
                if(icolor>ncolor) cycle
c
c       level number
c
                ichr=' '
                if(icolor<10) then
                    call sint(ichr(3:3),nchr,icolor)
                else
                    call sint(ichr(2:2),nchr,icolor)
                endif
                ii=ccolor(icolor,0_iknd,jp)
c
                x1=xl+real(nc-1,rknd)*dx
                x2=xl+real(nc,rknd)*dx
                xm=(2.0e0_rknd*x2+x1)/3.0e0_rknd
                y1=yt-real(nr,rknd)*dy
                y2=yt-real(nr-1,rknd)*dy
                ym=(y1+y2)/2.0e0_rknd
                call htext(x1,y1,xm,ym,4_iknd,ichr,1_iknd,q,t,2_iknd)
c
c       triangle icon
c
                x(1)=xm
                x(2)=(xm+x2)/2.0e0_rknd
                x(3)=x2
                x(4)=xm
                y(1)=y1
                y(2)=y1+s3*(x2-xm)
                y(3)=y1
                y(4)=y1
                do i=1,4
                    z(i)=zshift
                enddo
                ii=ccolor(icolor,0_iknd,jp)
                call pfill(x,y,z,3_iknd,ii)
                call pline(x,y,z,4_iknd,2_iknd)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine legnd2(jp,t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), save, dimension(3,6) :: mcic
            real(kind=rknd), dimension(4) :: x,y,z
            real(kind=rknd), dimension(25) :: tt,t
            real(kind=rknd), dimension(3,3) :: qq
            character(len=80) :: ichr
            character(len=80), save, dimension(4) :: title
            character(len=80), save, dimension(5) :: label
cy
            data title/'element quality','maximum angle',
     +          'minimum angle','mesh grading'/
            data label/'good','fair','poor','worst','average'/
            data mcic/2,2,1,1,3,2,2,1,3,3,2,4,3,2,5,4,2,6/
c
        call linit(tt,qq)
        size=tt(14)
        zshift=tt(5)
        xs=tt(15)
        ys=tt(16)
c
        xl=xs-size/2.0e0_rknd
        xr=xs+size/2.0e0_rknd
        yb=ys-size/2.0e0_rknd
        yt=ys+size/2.0e0_rknd
        s3=2.0e0_rknd/sqrt(3.0e0_rknd)
        dx=(xr-xl)/14.5e0_rknd
        dy=(yt-yb)/6.0e0_rknd
        h=min(0.9e0_rknd*dy,dx)
c
        do i=1,4
            z(i)=zshift
        enddo
c
        mxcolr=jp(17)
        if(mxcolr>=3.and.mxcolr<8) then
            ic=mxcolr-2
        else
            ic=6
        endif
c
        inplsw=jp(9)
        ii=min(inplsw-1,4)
        call fstr(ichr,nchr,title(ii),0_iknd)
        xxl=xl+2.25e0_rknd*dx
        xxr=xxl+15.0e0_rknd*dx
        yyl=yt-dy
        yyr=yyl+h
        call htext(xxl,yyl,xxr,yyr,15_iknd,ichr,
     +      -1_iknd,qq,tt,2_iknd)
c
        do i=1,5
            yy=yt-real(i+1,rknd)*dy
c
c       triangle icon
c
            if(i<=3) then
                x(1)=xl+0.25e0_rknd*dx
                x(2)=x(1)+s3*h
                x(3)=(x(1)+x(2))/2.0e0_rknd
                x(4)=x(1)
                y(1)=yy
                y(2)=yy
                y(3)=yy+h
                y(4)=yy
                icolor=mcic(i,ic)
                ii=ccolor(icolor,0_iknd,jp)
                call pfill(x,y,z,3_iknd,ii)
                call pline(x,y,z,4_iknd,2_iknd)
            endif
c
c     label
c
            call fstr(ichr,nchr,label(i),0_iknd)
            xxl=xl+2.25e0_rknd*dx
            xxr=xxl+7.0e0_rknd*dx
            yyl=yy
            yyr=yyl+h
            call htext(xxl,yyl,xxr,yyr,7_iknd,ichr,
     +          -1_iknd,qq,tt,2_iknd)
c
c      value
c
            ichr=' '
            call sfix(ichr(4:4),nchr,t(20+i),3_iknd)
cc          call sreal(ichr(4:4),nchr,t(20+i),3_iknd,1_iknd)
            if(nchr<7) then
                ii=nchr-3
                nchr=7
            else
                ii=4
            endif
            xxl=xl+9.25e0_rknd*dx
            xxr=xxl+5.0e0_rknd*dx
            call htext(xxl,yyl,xxr,yyr,nchr,ichr(ii:ii),
     +          1_iknd,qq,tt,2_iknd)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine legnd3(jp,t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(15) :: nchr
            real(kind=rknd), dimension(129) :: x,y,z
            real(kind=rknd), dimension(25) :: t,tt
            real(kind=rknd), dimension(3,3) :: qq
            real(kind=rknd), dimension(52) :: f
            character(len=80), dimension(15) :: ichr
cy
        call linit(tt,qq)
        size=tt(14)
        zshift=tt(5)
        xs=tt(15)
        ys=tt(16)
c
        ncolor=jp(5)
        if(ncolor<=0) return
        nshade=jp(16)
        iscale=jp(19)
c
c       set function values
c
        funmin=fscale(t(19),iscale,0_iknd)
        funmax=fscale(t(20),iscale,0_iknd)
        df=(funmax-funmin)/real(2*nshade+1,rknd)
        do i=1,2*nshade+2
            zz=funmin+df*real(i-1,rknd)
            f(i)=fscale(zz,iscale,1_iknd)
        enddo
c
        xm=xs+0.15e0_rknd*size
        ym=ys
        rmax=0.35e0_rknd*size
        pi=3.141592653589793e0_rknd
c
        if(t(19)>0.0e0_rknd) then
            rmin=rmax*0.15e0_rknd
        else
            rmin=0.0e0_rknd
        endif
        dr=(rmax-rmin)/real(2*nshade+1,rknd)
        dt=2.0e0_rknd*pi/real(ncolor,rknd)
        nn=max(64/ncolor,2)
        nn=min(nn,48)
        dq=dt/real(nn-1,rknd)
        n2=2*nn
        n3=n2+1
c
c        draw  regions
c
        do i=1,ncolor
            do j=1,2*nshade+1
                theta=real(i-1,rknd)*dt
                r1=rmin+real(j-1,rknd)*dr
                r2=rmin+real(j,rknd)*dr
                k=j-nshade-1
                ic=ccolor(i,k,jp)
                do k=1,nn
                    ang=theta+real(k-1,rknd)*dq
                    c=cos(ang)
                    s=sin(ang)
                    x(k)=xm+r2*c
                    y(k)=ym+r2*s
                    z(k)=zshift
                    x(n3-k)=xm+r1*c
                    y(n3-k)=ym+r1*s
                    z(n3-k)=zshift
                enddo
                x(n3)=x(1)
                y(n3)=y(1)
                z(n3)=z(1)
                call pfill(x,y,z,n2,ic)
                call pline(x,y,z,n3,2_iknd)
            enddo
        enddo
c
c       draw band across the bottom
c
        yb=ys-size*0.45e0_rknd
        yt=ys+size*0.45e0_rknd
        xl=xs-size*0.5e0_rknd
        xr=xl+size*0.05e0_rknd
        xc=xr+0.02e0_rknd*size
        xf=xc+0.2e0_rknd*size
c
        dy=(yt-yb)/real(2*nshade+1,rknd)
        do i=1,2*nshade+1
            k=i-nshade-1
            ic=ccolor(1_iknd,k,jp)
            x(1)=xl
            y(1)=yb+real(i-1,rknd)*dy
            z(1)=zshift
            x(2)=xr
            y(2)=y(1)
            z(2)=zshift
            x(3)=x(2)
            y(3)=yb+real(i,rknd)*dy
            z(3)=zshift
            x(4)=x(1)
            y(4)=y(3)
            z(4)=zshift
            x(5)=x(1)
            y(5)=y(1)
            z(5)=z(1)
            call pfill(x,y,z,4_iknd,ic)
            call pline(x,y,z,5_iknd,2_iknd)
        enddo
c
        mxchr=0
        do i=1,2*nshade+2
            ichr(i)=' '
            zc=f(i)
            if(zc<0.0e0_rknd) then
                call sreal(ichr(i),nchr(i),zc,3_iknd,1_iknd)
            else
                call sreal(ichr(i)(2:2),nn,zc,3_iknd,1_iknd)
                nchr(i)=nn+1
            endif
            mxchr=max(mxchr,nchr(i))
        enddo
        do i=1,2*nshade+2
            yc=yb+dy*real(i-1,rknd)-dy/2.0e0_rknd
            yf=yc+dy
            call htext(xc,yc,xf,yf,mxchr,ichr(i),-1_iknd,qq,tt,2_iknd)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine legnd4(jp,t,kdist)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(20) :: nchr
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(22) :: kdist
            real(kind=rknd), dimension(12) :: f
            real(kind=rknd), dimension(44) :: x,y,z
            real(kind=rknd), dimension(25) :: t,tt
            real(kind=rknd), dimension(3,3) :: qq
            character(len=80), dimension(15) :: ichr
cy
        call linit(tt,qq)
        size=tt(14)
        zshift=tt(5)
        xs=tt(15)
        ys=tt(16)
c
        ierrsw=jp(6)
        icolor=jp(5)
        if(icolor<=0) return
        ncolor=min(icolor,11)
        iscale=jp(19)
c
c       set function values
c
        zmin=fscale(t(19),iscale,0_iknd)
        zmax=fscale(t(20),iscale,0_iknd)
        df=(zmax-zmin)/real(ncolor,rknd)
        do i=1,ncolor+1
            zz=zmin+df*real(i-1,rknd)
            f(i)=fscale(zz,iscale,1_iknd)
        enddo
c
c       make boxes for each color
c
        xf=xs
        xi=xf-size*0.45e0_rknd
        xc=xf+0.04e0_rknd*size
        xx=xc+0.4e0_rknd*size
        yi=ys-size*0.45e0_rknd
        yf=ys+size*0.45e0_rknd
        yinc=0.04e0_rknd*size
        tic=0.02e0_rknd*size
        if(icolor==ncolor) yf=yi+(yf-yi)*ncolor/11.0e0_rknd
c
        do i=1,5
            z(i)=zshift
        enddo
        x(1)=xi
        x(2)=xf
        x(3)=xf
        x(4)=xi
        x(5)=xi
        dy=(yf-yi)/real(icolor,rknd)
        do i=1,icolor
            y(1)=yi+dy*real(i,rknd)
            y(2)=y(1)
            y(3)=yi+dy*real(i-1,rknd)
            y(4)=y(3)
            ii=ccolor(i,0_iknd,jp)
            call pfill(x,y,z,4_iknd,ii)
        enddo
c
c       draw the border and tick marks
c
        y(1)=yi
        y(2)=yi
        y(3)=yf
        y(4)=yf
        y(5)=yi
        call pline(x,y,z,5_iknd,2_iknd)
c
c
        x(1)=xf
        scale=(yf-yi)/real(ncolor,rknd)
        do i=0,ncolor
            yp=yi+scale*i
            x(2)=xf+tic
            y(1)=yp
            y(2)=yp
            call pline(x,y,z,2_iknd,2_iknd)
        enddo
c
c       compute error distribution
c
        if(ierrsw==1.and.df/=0.0e0_rknd) then
            num=2*ncolor
            kdm=0
            do i=1,num
                kdm=max(kdm,kdist(i))
            enddo
            ddy=(yf-yi)/real(num,rknd)
            xxi=xi+0.05e0_rknd*(xf-xi)
            ddx=0.9e0_rknd*(xf-xi)
            do i=1,num
                j=2*i-1
                x(j)=xxi+ddx*(real(kdist(i),rknd)/real(kdm,rknd))
                x(j+1)=x(j)
                y(j+1)=yi+ddy*real(i,rknd)
                y(j)=yi+ddy*real(i-1,rknd)
                z(j)=zshift
                z(j+1)=zshift
            enddo
            num=2*num
            call pline(x,y,z,num,2_iknd)
        endif
c
c       label the tick marks
c
        mxchr=0
        do i=1,ncolor+1
            ichr(i)=' '
            zc=f(i)
            if(zc<0.0e0_rknd) then
                call sreal(ichr(i)(2:2),nn,zc,3_iknd,1_iknd)
                nchr(i)=nn+1
            else
                call sreal(ichr(i)(3:3),nn,zc,3_iknd,1_iknd)
                nchr(i)=nn+2
            endif
            mxchr=max(mxchr,nchr(i))
        enddo
        do i=1,ncolor+1
            yc=yi+scale*real(i-1,rknd)-yinc/2.0e0_rknd
            yf=yc+yinc
            call htext(xc,yc,xx,yf,mxchr,ichr(i),-1_iknd,qq,tt,2_iknd)
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cdist(jp,t,e,kdist)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(22) :: kdist
            real(kind=rknd), dimension(*) :: e
            real(kind=rknd), dimension(25) :: t
cy
c
        num=2*min(jp(5),11)
        ntf=jp(1)
        iscale=jp(19)
c
c       set function values
c
        zmin=fscale(t(19),iscale,0_iknd)
        zmax=fscale(t(20),iscale,0_iknd)
        if(zmax>zmin) then
            dd=real(num,rknd)/(zmax-zmin)
        else
            dd=0.0e0_rknd
        endif
c
        do i=1,num
            kdist(i)=0
        enddo
        do i=1,ntf
            ff=(fscale(e(i),iscale,0_iknd)-zmin)*dd
            iq=max(1,int(ff)+1)
            iq=min(num,iq)
            kdist(iq)=kdist(iq)+1
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine legnd5(jp,kdist)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(22) :: kdist
            real(kind=rknd), dimension(44) :: x,y,z
            real(kind=rknd), dimension(25) :: tt
            real(kind=rknd), dimension(3,3) :: qq
            character(len=80), dimension(15) :: ichr
cy
        call linit(tt,qq)
        size=tt(14)
        zshift=tt(5)
        xs=tt(15)
        ys=tt(16)
c
        ncolor=10
c
c       make boxes for each color
c
        xf=xs
        xi=xf-size*0.45e0_rknd
        xc=xf+0.04e0_rknd*size
        xx=xc+0.4e0_rknd*size
        yi=ys-size*0.45e0_rknd
        yf=ys+size*0.45e0_rknd
        yinc=0.04e0_rknd*size
c
        do i=1,5
            z(i)=zshift
        enddo
        x(1)=xi
        x(2)=xf
        x(3)=xf
        x(4)=xi
        x(5)=xi
        dy=(yf-yi)/real(ncolor,rknd)
        do i=1,ncolor
            y(1)=yi+dy*real(i,rknd)
            y(2)=y(1)
            y(3)=yi+dy*real(i-1,rknd)
            y(4)=y(3)
            ii=ccolor(i,0_iknd,jp)
            call pfill(x,y,z,4_iknd,ii)
        enddo
c
c       draw the border and tick marks
c
        y(1)=yi
        y(2)=yi
        y(3)=yf
        y(4)=yf
        y(5)=yi
        call pline(x,y,z,5_iknd,2_iknd)
c
c
c       compute error distribution
c
        kdm=0
        do i=1,ncolor
            kdm=max(kdm,kdist(i))
        enddo
        ddy=(yf-yi)/real(ncolor,rknd)
        xxi=xi+0.05e0_rknd*(xf-xi)
        ddx=0.9e0_rknd*(xf-xi)
        do i=1,ncolor
            j=2*i-1
            x(j)=xxi+ddx*(real(kdist(i),rknd)/real(kdm,rknd))
            x(j+1)=x(j)
            y(j+1)=yi+ddy*real(i,rknd)
            y(j)=yi+ddy*real(i-1,rknd)
            z(j)=zshift
            z(j+1)=zshift
        enddo
        num=2*ncolor
        call pline(x,y,z,num,2_iknd)
c
c       label the tick marks
c
        mxchr=0
        do i=1,ncolor
            ichr(i)=' '
            if(i<10) then
                call sint(ichr(i)(3:3),nn,i)
            else
                call sint(ichr(i)(2:2),nn,i)
            endif
        enddo
        mxchr=3
        do i=1,ncolor
            yc=yi+dy*real(i-1,rknd)+yinc/2.0e0_rknd
            yf=yc+yinc
            call htext(xc,yc,xx,yf,mxchr,ichr(i),-1_iknd,qq,tt,2_iknd)
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cdist1(jp,iclr,kdist)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(22) :: kdist
            integer(kind=iknd), dimension(*) :: iclr
cy
c
        mxord=9
        ntf=jp(1)
c
        do i=1,mxord+1
            kdist(i)=0
        enddo
        do i=1,ntf
            iq=max(1,iclr(i))
            iq=min(mxord,iq)
            kdist(iq)=kdist(iq)+1
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine legnd6(jp,iptr)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), save, dimension(50) :: mcic
            integer(kind=iknd), save, dimension(6) :: jc
            real(kind=rknd), dimension(5) :: x,y,z
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(25) :: tt
            character(len=80) :: ichr
            character(len=80), save, dimension(5) :: title
            character(len=80), save, dimension(50) :: label
cy
            data title( 1)/'adaptive mesh option'/
            data label( 1)/'error estimate      '/
            data label( 2)/'refine              '/
            data label( 3)/'unrefine            '/
            data label( 4)/'unrefine/refine     '/
            data label( 5)/'uniform/load balance'/
            data label( 6)/'mesh smoothing      '/
            data (mcic(i),i= 1, 6)/4,2,3,1,5,6/
c
            data title( 2)/'continuation options'/
            data label( 7)/'initialization      '/
            data label( 8)/'regular point       '/
            data label( 9)/'limit point         '/
            data label(10)/'bifurcation point   '/
            data label(11)/'adaptive mesh       '/
            data label(12)/'adaptive mesh (mpi) '/
            data (mcic(i),i= 7,12)/1,4,2,6,3,5/
c
            data title( 3)/'time history        '/
            data label(13)/'new step            '/
            data label(14)/'redone step         '/
            data (mcic(i),i=13,14)/6,4/
c
            data title( 4)/'interior point method'/
            data label(15)/'initialization      '/
            data label(16)/'regular point       '/
            data label(17)/'switch lambda       '/
            data label(18)/'mpi solve           '/
            data (mcic(i),i=15,18)/6,2,5,3/
c
            data jc/1,7,13,15,19,19/
c
        call linit(tt,q)
        size=tt(14)
        zshift=tt(5)
        xs=tt(15)
        ys=tt(16)
c
        xl=xs-size/2.0e0_rknd
        xr=xs+size/2.0e0_rknd
        yb=ys-size/2.0e0_rknd
        yt=ys+size/2.0e0_rknd
        dx=(xr-xl)/20.5e0_rknd
        dy=(yt-yb)/9.0e0_rknd
        h=min(0.9e0_rknd*dy,dx)
c
        call fstr(ichr,nchr,title(iptr),0_iknd)
        xxl=xl+2.25e0_rknd*dx
        xxr=xxl+17.0e0_rknd*dx
        yyl=yt-dy
        yyr=yyl+h
        call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +      -1_iknd,q,tt,2_iknd)
c
        i1=jc(iptr)
        i2=jc(iptr+1)-1
        do i=i1,i2
            yy=yt-real(i-i1+2,rknd)*dy
c
c       square icon
c
            x(1)=xl+0.25e0_rknd*dx
            x(2)=x(1)+h
            x(3)=x(2)
            x(4)=x(1)
            x(5)=x(1)
            y(1)=yy
            y(2)=yy
            y(3)=yy+h
            y(4)=y(3)
            y(5)=y(1)
            do j=1,5
                z(j)=zshift
            enddo
            ii=ccolor(mcic(i),0_iknd,jp)
            call pfill(x,y,z,4_iknd,ii)
            call pline(x,y,z,5_iknd,2_iknd)
c
c     label
c
            call fstr(ichr,nchr,label(i),0_iknd)
            xxl=xl+2.25e0_rknd*dx
            xxr=xxl+20.0e0_rknd*dx
            yyl=yy
            yyr=yyl+h
            call htext(xxl,yyl,xxr,yyr,20_iknd,ichr,
     +          -1_iknd,q,tt,2_iknd)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        function fscale(f,iscale,invrse)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
cy
c       set scaling function
c
        if(iscale==0) then
c
c       linear scale
c
            fscale=f
            return
        else if(iscale==1) then
c
c       log scale
c
            if(invrse==0) then
                fscale=log(f)
                return
            else
                fscale=exp(f)
                return
            endif
        else
c
c       arcsinh scale
c
            if(invrse==0) then
                af=abs(f)
                if(af<1.0e0_rknd) then
                    q=sqrt(1.0e0_rknd+f*f)+af
                    fx=log(q)
                    fscale=fx+(af-sinh(fx))/cosh(fx)
                else
                    q=1.0e0_rknd/f
                    q=sqrt(1.0e0_rknd+q*q)+1.0e0_rknd
                    fscale=log(q)+log(af)
                endif
                if(f<0.0e0_rknd) fscale=-fscale
                return
            else
                fscale=sinh(f)
                return
            endif
        endif
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dgrid
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(6) :: x,y,z
            real(kind=rknd), dimension(25) :: tt
            real(kind=rknd), dimension(3,3) :: q
cy
c       helps locating current window (draw boundary in small window)
c
        call linit(tt,q)
        zshift=1.0e0_rknd
        size=tt(14)
        x0=tt(15)-size/2.0e0_rknd
        x1=tt(15)+size/2.0e0_rknd
        y0=tt(16)-size/2.0e0_rknd
        y1=tt(16)+size/2.0e0_rknd
c
c       mark magnified area
c
        icolor=1
        z(1)=zshift
        z(2)=zshift
        h=size/20.0e0_rknd
        do i=1,10
            x(1)=x0+real(2*i-1,rknd)*h
            x(2)=x(1)
            y(1)=y0
            y(2)=y1
            call pline(x,y,z,2_iknd,icolor)
            x(1)=x0
            x(2)=x1
            y(1)=y0+real(2*i-1,rknd)*h
            y(2)=y(1)
            call pline(x,y,z,2_iknd,icolor)
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine vlabel(len,jp,itnode,itedge,ibndry,ibedge,
     +      vx,vy,sf,q,t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(len) :: vtype,iseed
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(2,*) :: ibedge
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(len) :: rad
            real(kind=rknd), dimension(3,3) :: q
            character(len=80) :: ichr
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       print vertex number
c
        ntf=jp(1)
        nvf=jp(2)
        nbf=jp(3)
        numbrs=jp(21)
        scale=t(3)
c
c
        if(numbrs==8) then
            angmin=1.0e-3_rknd
            arcmax=0.26e0_rknd
            call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,
     +          itedge,ibedge,vtype,iseed,angmin,arcmax)
        endif
c
        rmax=0.05e0_rknd/scale
        do i=1,nvf
            rad(i)=rmax
        enddo
c
        do it=1,ntf
            do j=1,3
               j1=itnode(index(2,j),it)
               j2=itnode(index(3,j),it)
               h=sqrt((vx(j1)-vx(j2))**2+(vy(j1)-vy(j2))**2)/2.1e0_rknd
               rad(j1)=min(h,rad(j1))
               rad(j2)=min(h,rad(j2))
            enddo
        enddo
c
        do k=1,nvf
            xc=vx(k)
            yc=vy(k)
            r=rad(k)
c
            if(numbrs==8) then
                kk=vtype(k)
            else
                kk=k
            endif
            call sint(ichr,nchr,kk)
            ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd
            delta=r/sqrt(1.0e0_rknd+ratio*ratio)
            x1=xc-ratio*delta
            x2=xc+ratio*delta
            y1=yc-delta
            y2=yc+delta
c
            call htext(x1,y1,x2,y2,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine blabel(jp,itnode,ibndry,ibedge,vx,vy,sf,q,t,
     +      nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(2,15) :: values
            real(kind=rknd), dimension(10) :: rl
            character(len=80) :: ichr
cy
            external sxy
            data index/1,2,3,2,3,1,3,1,2/
c
c       print edge numbers or midpoint numbers
c
        nbf=jp(3)
        numbrs=jp(21)
        scale=t(3)
c
c       find local h for vertices
c
        rmax=0.05e0_rknd/scale
        do ib=1,nbf
           r=rmax
           do k=1,2
                if(ibedge(k,ib)==0) cycle
                it=ibedge(k,ib)/4
                j=ibedge(k,ib)-4*it
                i1=itnode(j,it)
                i2=itnode(index(2,j),it)
                i3=itnode(index(3,j),it)
                x2=vx(i2)-vx(i1)
                y2=vy(i2)-vy(i1)
                x3=vx(i3)-vx(i1)
                y3=vy(i3)-vy(i1)
                d1=sqrt((x2-x3)**2+(y2-y3)**2)/2.5e0_rknd
                d2=sqrt((x2+x3)**2+(y2+y3)**2)/5.0e0_rknd
                r=min(d1,d2,r)
            enddo
c
c
            j1=ibndry(1,ib)
            j2=ibndry(2,ib)
            jm=ibndry(3,ib)
c
            i=ib
            if(numbrs==4) i=jm
            if(numbrs==5) i=ibndry(4,ib)
            if(numbrs==6) i=ibndry(7,ib)
            if(jm>0) then
                call midpt(vx(j1),vy(j1),vx(j2),
     +              vy(j2),sf(1,ib),sf(2,ib),xc,yc)
            else if(jm<0) then
                itag=-jm
                theta=(sf(1,ib)+sf(2,ib))/2.0e0_rknd
                do m=1,2+nrl
                    values(1,m)=0.0e0_rknd
                    values(2,m)=0.0e0_rknd
                enddo
                call sxy(rl,theta,itag,values)
                xc=values(1,1)
                yc=values(2,1)
            else
                if(numbrs==4) cycle
                xc=(vx(j1)+vx(j2))/2.0e0_rknd
                yc=(vy(j1)+vy(j2))/2.0e0_rknd
            endif
c
            call sint(ichr,nchr,i)
            ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd
            delta=r/sqrt(1.0e0_rknd+ratio*ratio)
            x1=xc-ratio*delta
            x2=xc+ratio*delta
            y1=yc-delta
            y2=yc+delta
            call htext(x1,y1,x2,y2,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tlabel(jp,itnode,itdof,vx,vy,q,t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(3) :: iords
            integer(kind=iknd), dimension(25) :: jp
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(25) :: t
            character(len=80) :: ichr
cy
        ntf=jp(1)
        scale=t(3)
        numbrs=jp(21)
c
        rmax=0.05e0_rknd/scale
c
        do it=1,ntf
            if(numbrs==10) then
                call locord(it,ndof,ii,iords,itdof)
            else
                ii=it
            endif
c
c       compute center of inscribed circle
c
            call incirc(vx(itnode(1,it)),vy(itnode(1,it)),
     +          vx(itnode(2,it)),vy(itnode(2,it)),
     1          vx(itnode(3,it)),vy(itnode(3,it)),xc,yc,r)
            r=min(rmax,r)
c
c       compute number width (max 10 digits)
c
            call sint(ichr,nchr,ii)
            ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd
            delta=r/sqrt(1.0e0_rknd+ratio*ratio)
            x1=xc-ratio*delta
            x2=xc+ratio*delta
            y1=yc-delta
            y2=yc+delta
c
            call htext(x1,y1,x2,y2,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine rlabel(jp,itnode,jt,vx,vy,q,t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(*) :: jt
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(25) :: t
            character(len=80) :: ichr
cy
        ntf=jp(8)
        scale=t(3)
c
        rmax=0.05e0_rknd/scale
c
        do irgn=1,ntf
c
c       compute center of inscribed circle
c
            xc=0.0e0_rknd
            yc=0.0e0_rknd
            r=0.0e0_rknd
            it1=jt(irgn)
            it2=jt(irgn+1)-1
            do it=it1,it2
                call incirc(vx(itnode(1,it)),vy(itnode(1,it)),
     +              vx(itnode(2,it)),vy(itnode(2,it)),
     1              vx(itnode(3,it)),vy(itnode(3,it)),xcc,ycc,rr)
                if(rr>r) then
                    r=rr
                    xc=xcc
                    yc=ycc
                endif
            enddo
            r=min(rmax,r)
c
c       compute number width (max 10 digits)
c
            call sint(ichr,nchr,irgn)
            ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd
            delta=r/sqrt(1.0e0_rknd+ratio*ratio)
            x1=xc-ratio*delta
            x2=xc+ratio*delta
            y1=yc-delta
            y2=yc+delta
            call htext(x1,y1,x2,y2,nchr,ichr,0_iknd,q,t,2_iknd)
c
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine plabel(nproc,jp,itnode,vx,vy,q,t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(25) :: jp
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(nproc) :: xc,yc,r
            character(len=80) :: ichr
cy
        ntf=jp(1)
cc      nproc=jp(23)
        scale=t(3)
c
        rmax=0.05e0_rknd/scale
c
        do i=1,nproc
            r(i)=-1.0e0_rknd
        enddo
        do i=1,ntf
            call incirc(vx(itnode(1,i)),vy(itnode(1,i)),
     +          vx(itnode(2,i)),vy(itnode(2,i)),
     1          vx(itnode(3,i)),vy(itnode(3,i)),xcc,ycc,rr)
            irgn=itnode(4,i)
            if(rr>r(irgn)) then
                r(irgn)=rr
                xc(irgn)=xcc
                yc(irgn)=ycc
            endif
        enddo
        do irgn=1,nproc
c
c       compute center of inscribed circle
c
            r(irgn)=min(rmax,r(irgn))
c
c       compute number width (max 10 digits)
c
            call sint(ichr,nchr,irgn)
            ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd
            delta=r(irgn)/sqrt(1.0e0_rknd+ratio*ratio)
            x1=xc(irgn)-ratio*delta
            x2=xc(irgn)+ratio*delta
            y1=yc(irgn)-delta
            y2=yc(irgn)+delta
            call htext(x1,y1,x2,y2,nchr,ichr,0_iknd,q,t,2_iknd)
c
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dlabel(ndf,jp,itnode,itdof,vx,vy,q,t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(100) :: idof
            integer(kind=iknd), dimension(3) :: iords
            integer(kind=iknd), dimension(5) :: lptr
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(ndf) :: rad,x,y
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(3) :: h
            character(len=80) :: ichr
            common /pltmg1/ic(3,363),jc(12)
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       print vertex number
c
        ntf=jp(1)
        scale=t(3)
c
        rmax=0.05e0_rknd/scale
        do i=1,ndf
            rad(i)=rmax
        enddo
c
        do it=1,ntf
            call l2gmap(it,idof,ndof,iord,iords,itdof)
            call mkgptr(iord,iords,lptr)
c
            do j=1,3
                j1=itnode(index(2,j),it)
                j2=itnode(index(3,j),it)
                h(j)=sqrt((vx(j1)-vx(j2))**2+(vy(j1)-vy(j2))**2)
c
                x(idof(j))=vx(itnode(j,it))
                y(idof(j))=vy(itnode(j,it))
            enddo
c
            do j=1,3
                ss=1.0e0_rknd/real(iords(j),rknd)
                h(j)=h(j)*ss/3.0e0_rknd
                ii=jc(iords(j))+3+(j-1)*(iords(j)-1)-lptr(j)
                do k=lptr(j),lptr(j+1)-1
                    kk=ii+k
                    x(idof(k))=(x(idof(1))*real(ic(1,kk),rknd)
     +                     +x(idof(2))*real(ic(2,kk),rknd)
     1                     +x(idof(3))*real(ic(3,kk),rknd))*ss
                    y(idof(k))=(y(idof(1))*real(ic(1,kk),rknd)
     +                     +y(idof(2))*real(ic(2,kk),rknd)
     1                     +y(idof(3))*real(ic(3,kk),rknd))*ss
                enddo
            enddo
c
            ss=1.0e0_rknd/real(iord,rknd)
            ii=jc(iord)+3*iord-lptr(4)
            do k=lptr(4),ndof
                kk=ii+k
                x(idof(k))=(x(idof(1))*real(ic(1,kk),rknd)
     +                 +x(idof(2))*real(ic(2,kk),rknd)
     1                 +x(idof(3))*real(ic(3,kk),rknd))*ss
                y(idof(k))=(y(idof(1))*real(ic(1,kk),rknd)
     +                 +y(idof(2))*real(ic(2,kk),rknd)
     1                 +y(idof(3))*real(ic(3,kk),rknd))*ss
            enddo
c
            hh=min(h(1),h(2),h(2))
            do i=1,ndof
                rad(idof(i))=min(rad(idof(i)),hh)
            enddo
        enddo
c
        do k=1,ndf
            xc=x(k)
            yc=y(k)
            r=rad(k)
c
            call sint(ichr,nchr,k)
            ratio=real(nchr,rknd)*20.0e0_rknd/21.0e0_rknd
            delta=r/sqrt(1.0e0_rknd+ratio*ratio)
            x1=xc-ratio*delta
            x2=xc+ratio*delta
            y1=yc-delta
            y2=yc+delta
c
            call htext(x1,y1,x2,y2,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine title0(title,isw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            character(len=80) :: title,ichr
cy
c       draw the title for the picture
c
        call linit(t,q)
        size=t(14)
        xl=t(15)-size/2.0e0_rknd
        xr=t(15)+size/2.0e0_rknd
        if(isw==1) xr=xr+0.5e0_rknd
        yb=t(16)+size/2.0e0_rknd
        yt=t(16)+t(3)/2.0e0_rknd
        yl=yb+(yt-yb)*0.25e0_rknd
        yr=yb+(yt-yb)*0.75e0_rknd
        call fstr(ichr,nchr,title,0_iknd)
        call htext(xl,yl,xr,yr,nchr,ichr,0_iknd,q,t,2_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine gphplt(ip,rp,sp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), dimension(25) :: jp
            real(kind=rknd), dimension(10) :: red,green,blue
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(3,50) :: atime
            real(kind=rknd), allocatable, dimension(:) :: ptime,pstat
            character(len=80), dimension(100) :: sp
cy
c       storage allocation
c
        call setcom(ip)
c
        ip(25)=0
c
        do i=1,25
            jp(i)=0
        enddo
        iprob=abs(ip(6))
        mxcolr=max(2,ip(51))
        igrsw=ip(54)
        if(igrsw>6.or.igrsw<-5) igrsw=0
c
        mpisw=ip(48)
        nproc=ip(49)
        irgn=ip(50)
        jp(1)=ip(1)
        jp(2)=nproc
        jp(3)=irgn
c
        jp(4)=1
        jp(5)=6
        jp(7)=iprob
        jp(17)=mxcolr
        jp(18)=min(mxcolr,jp(5)+2)
        jp(10)=igrsw
        jp(12)=mpisw
        iisw=0
        if(mpisw==1) then
            iisw=1
            allocate(ptime(nproc),pstat(4*nproc))
            if(abs(igrsw)==2) call extim(atime,ptime)
            if(igrsw==-3) call exstat(rp,pstat)
            mpirgn=ip(47)
            if(mpirgn/=0) then
                if(mpirgn/=irgn) go to 10
                mpisw=-1
                jp(12)=mpisw
            else
                if(irgn/=1) go to 10
            endif
        endif
c
        jp(13)=ip(64)
        jp(14)=ip(65)
        jp(15)=ip(66)
c
        call clrmap(red,green,blue,jp)
c
        call pltutl(jp(18),red,green,blue)
c
        call pgraph(jp,ip,rp,sp,atime,ptime,pstat)
c
        call pltutl(-1_iknd,red,green,blue)
c
        sp(11)='gphplt: ok'
        ip(25)=0
   10   if(iisw==1) deallocate(ptime,pstat)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pgraph(jp,ip,rp,sp,atime,ptime,pstat)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), save :: len=50
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(3,*) :: atime
            real(kind=rknd), dimension(*) :: ptime
            real(kind=rknd), dimension(4,*) :: pstat
            character(len=80), dimension(100) :: sp
            common /pltmg7/time(3,50),hist(22,30)
cy
c     output graphs
c
        iprob=jp(7)
        igrsw=jp(10)
        mpisw=jp(12)
c
c       newton, mg history, ilu statistics
c
        if(abs(igrsw)<=1) then
            call pframe(4_iknd)
            call title0(sp(3),0_iknd)
            if(igrsw==0) call nwtplt(hist(1,11),jp)
c***        if(igrsw==0) call nwtprt(hist(1,11))
            if(igrsw==1) call hbplt(hist(1,7),4_iknd,1_iknd,jp)
            if(igrsw==-1) call kaplt(ip,jp)
            call pframe(-4_iknd)
c
            call pframe(2_iknd)
            if(igrsw/=1) then
                call hbplt(hist(1,7),4_iknd,1_iknd,jp)
            else
                call kaplt(ip,jp)
            endif
            call pframe(-2_iknd)
c
            call pframe(3_iknd)
            if(igrsw/=0) then
                call nwtplt(hist(1,11),jp)
            else
                call kaplt(ip,jp)
            endif
            call pframe(-3_iknd)
c
c       timing statistics
c
        else if(abs(igrsw)==2) then
            if(mpisw/=1) then
                do i=1,len
                    atime(1,i)=time(1,i)
                    atime(2,i)=time(2,i)
                    atime(3,i)=time(3,i)
                enddo
            endif
c
            call pframe(4_iknd)
            call title0(sp(3),0_iknd)
            if(igrsw==2) call timplt(atime,jp)
            if(igrsw==-2) call pieplt(atime,jp)
            call pframe(-4_iknd)
c
            call pframe(2_iknd)
            if(igrsw==2) call pieplt(atime,jp)
            if(igrsw==-2) call subplt(atime,jp)
            call pframe(-2_iknd)
c
            call pframe(3_iknd)
            if(mpisw==1) then
                call aveplt(ptime,jp)
c***            call aveprt(ptime,jp)
            else
                call kaplt(ip,jp)
cc              call nwtplt(hist(1,11),jp)
            endif
            call pframe(-3_iknd)
c
c       continuation path / time step history
c
        else if(igrsw==3) then
            if(iprob==3.or.iprob==6) then
                call pframe(4_iknd)
                call title0(sp(3),0_iknd)
                if(iprob==3) call pthplt(jp)
                if(iprob==6) call tmhist(jp,1_iknd)
                call pframe(-4_iknd)
            else if(iprob==2.or.iprob==4.or.iprob==5) then
                call pframe(5_iknd)
                call title0(sp(3),0_iknd)
                call ipmplt(jp)
                call pframe(-5_iknd)
            endif
c
            call pframe(2_iknd)
            if(iprob==3) call legnd6(jp,2_iknd)
            if(iprob==2) call legnd6(jp,4_iknd)
            if(iprob>=4.and.iprob<=6) call legnd6(jp,4_iknd)
            if(iprob==6) call legnd6(jp,3_iknd)
            call pframe(-2_iknd)
c
            call pframe(3_iknd)
            if(iprob==3) call hbplt(hist(1,14),1_iknd,2_iknd,jp)
            if(iprob==6) call tmhist(jp,2_iknd)
            call pframe(-3_iknd)
c
c       load balance
c
        else if(igrsw==-3) then
            call pframe(4_iknd)
            call title0(sp(3),0_iknd)
            call lbplt(jp,pstat,1_iknd)
            call pframe(-4_iknd)
c
            call pframe(2_iknd)
            call lbplt(jp,pstat,0_iknd)
            call pframe(-2_iknd)
c
            call pframe(3_iknd)
            call hbplt(hist(1,27),4_iknd,3_iknd,jp)
            call pframe(-3_iknd)
c
c       error estimates
c
        else if(abs(igrsw)==4) then
ccc         call lsfit
            call pframe(4_iknd)
            call title0(sp(3),0_iknd)
            call pframe(-4_iknd)
c
            i1=(12-igrsw)/8
            i2=3-i1
            call pframe(5_iknd)
            call errplt(hist,i1,jp)
            call pframe(-5_iknd)
c
            call pframe(2_iknd)
            call legnd6(jp,1_iknd)
            call pframe(-2_iknd)
c
            call pframe(3_iknd)
            call errplt(hist,i2,jp)
            call pframe(-3_iknd)
c
c       ip, rp, sp arrays
c
        else if(abs(igrsw)>=5.and.abs(igrsw)<=6) then
            call pframe(1_iknd)
            call title0(sp(3),1_iknd)
            if(igrsw==5) call prtip(ip,jp)
            if(igrsw==-5) call prtsp(sp,jp)
            if(igrsw==6) call prtrp(rp,jp)
            call pframe(-1_iknd)
        endif
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine prtip(ip,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(100) :: ip,ic
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(3) :: icolor
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            character(len=15), dimension(300) :: name0
            character(len=15), dimension(100) :: name
            character(len=80) :: ichr
cy
c       print ip array
c
        call linit(t,q)
        mxcolr=jp(17)
        if(mxcolr>=8) then
            icolor(1)=2
            icolor(2)=ccolor(2_iknd,0_iknd,jp)
            icolor(3)=ccolor(6_iknd,0_iknd,jp)
         else
            icolor(1)=2
            icolor(2)=2
            icolor(3)=2
        endif
        call getnam(name0,nlen)
        do i=1,100
            name(i)=' '
            ic(i)=icolor(1)
            call sint(ichr,length,i)
            name(i)(4-length:3)=ichr(1:length)
        enddo
        do i=1,nlen
            if(name0(i)(15:15)=='i') then
                call cint(name0(i),3_iknd,indx,jerr)
                name(indx)(4:10)=name0(i)(4:10)
                if(name0(i)(12:13)==' ') then
                    ic(indx)=icolor(2)
                else
                    ic(indx)=icolor(3)
                endif
            endif
        enddo
c
        size=t(14)
        dy=size/25.0e0_rknd
        dx=(size+0.5e0_rknd)/4.0e0_rknd
        h=min(dy*0.9e0_rknd,dx/20.0e0_rknd)
c
        do i=1,25
            do j=1,4
                k=(j-1)*25+i
                xl=real(j-1,rknd)*dx+.05e0_rknd+dx/10.0e0_rknd
                xr=xl+dx/2.0e0_rknd
                yl=0.95e0_rknd-(real(i,rknd)*dy)
                yr=yl+h
                call htext(xl,yl,xr,yr,10_iknd,name(k),
     +              -1_iknd,q,t,ic(k))
                xl=xl+dx/2.0e0_rknd
                xr=xl+3.0e0_rknd*dx/10.0e0_rknd
                ichr=' '
                call sint(ichr(6:6),nchr,ip(k))
                m=min(nchr,6)
                nchr=max(6,nchr)
                call htext(xl,yl,xr,yr,nchr,ichr(m:m),
     +              1_iknd,q,t,ic(k))
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine prtrp(rp,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(3) :: icolor
            integer(kind=iknd), dimension(100) :: ic
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(100) :: rp
            character(len=15), dimension(300) :: name0
            character(len=15), dimension(100) :: name
            character(len=80) :: ichr
cy
c       print rp array
c
        call linit(t,q)
        mxcolr=jp(17)
        if(mxcolr>=8) then
            icolor(1)=2
            icolor(2)=ccolor(2_iknd,0_iknd,jp)
            icolor(3)=ccolor(6_iknd,0_iknd,jp)
         else
            icolor(1)=2
            icolor(2)=2
            icolor(3)=2
        endif
        call getnam(name0,nlen)
        do i=1,100
            name(i)=' '
            ic(i)=icolor(1)
            call sint(ichr,length,i)
            name(i)(4-length:3)=ichr(1:length)
        enddo
        do i=1,nlen
            if(name0(i)(15:15)/='r') cycle
            call cint(name0(i),3_iknd,indx,jerr)
            name(indx)(4:10)=name0(i)(4:10)
            if(name0(i)(12:13)==' ') then
                ic(indx)=icolor(2)
            else
                ic(indx)=icolor(3)
            endif
        enddo
c
        size=t(14)
        dy=size/25.0e0_rknd
        dx=(size+0.5e0_rknd)/4.0e0_rknd
        h=min(dy*0.9e0_rknd,dx/20.0e0_rknd)
c
        do i=1,25
            do j=1,4
                k=(j-1)*25+i
                xl=real(j-1,rknd)*dx+.05e0_rknd+dx/22.0e0_rknd
                xr=xl+10.0e0_rknd*dx/22.0e0_rknd
                yl=0.95e0_rknd-(real(i,rknd)*dy)
                yr=yl+h
                call htext(xl,yl,xr,yr,10_iknd,name(k),
     +              -1_iknd,q,t,ic(k))
                xl=xr+dx/22.0e0_rknd
                xr=xl+9.0e0_rknd*dx/22.0e0_rknd
                ichr=' '
                call sreal(ichr(9:9),nchr,rp(k),3_iknd,0_iknd)
                m=min(nchr,9)
                nchr=max(9,nchr)
                call htext(xl,yl,xr,yr,nchr,ichr(m:m),
     +              1_iknd,q,t,ic(k))
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine prtsp(sp,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(3) :: icolor
            integer(kind=iknd), dimension(100) :: ic
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            character(len=15), dimension(300) :: name0
            character(len=15), dimension(100) :: name
            character(len=80) :: ichr
            character(len=80), dimension(100) :: sp
cy
c       print sp array
c
        call linit(t,q)
        mxcolr=jp(17)
        if(mxcolr>=8) then
            icolor(1)=2
            icolor(2)=ccolor(2_iknd,0_iknd,jp)
            icolor(3)=ccolor(6_iknd,0_iknd,jp)
         else
            icolor(1)=2
            icolor(2)=2
            icolor(3)=2
        endif
        call getnam(name0,nlen)
        do i=1,100
            name(i)=' '
            ic(i)=icolor(1)
            call sint(ichr,length,i)
            name(i)(4-length:3)=ichr(1:length)
        enddo
        do i=1,nlen
            isw=1
            if(name0(i)(15:15)=='r') isw=0
            if(name0(i)(15:15)=='i') isw=0
            if(isw==1) then
                call cint(name0(i),3_iknd,indx,jerr)
                name(indx)(4:10)=name0(i)(4:10)
                if(name0(i)(12:13)==' ') then
                    ic(indx)=icolor(2)
                else
                    ic(indx)=icolor(3)
                endif
            endif
        enddo
c
        size=t(14)
        dy=size/25.0e0_rknd
        dx=(size+0.5e0_rknd)/4.0e0_rknd
        h=min(dy*0.9e0_rknd,dx/20.0e0_rknd)
c
        do i=1,25
            do j=1,2
                k=(j-1)*25+i
                xl=real(j-1,rknd)*dx*2.0e0_rknd
     +              +.05e0_rknd+dx/10.0e0_rknd
                xr=xl+dx/2.0e0_rknd
                yl=0.95e0_rknd-(real(i,rknd)*dy)
                yr=yl+h
                call htext(xl,yl,xr,yr,10_iknd,name(k),
     +              -1_iknd,q,t,ic(k))
                xl=xl+dx/2.0e0_rknd
                xr=xl+1.5e0_rknd*dx
                call fstr(ichr,nchr,sp(k),0_iknd)
                if(nchr>0) call htext(xl,yl,xr,yr,nchr,ichr,
     +              -1_iknd,q,t,ic(k))
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine lbplt(jp,pstat,ipix)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(3) :: icolor
            integer(kind=iknd) :: ccolor
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(4) :: sfact
            real(kind=rknd), dimension(4,*) :: pstat
            real(kind=rknd), dimension(10) :: x,y,z,sr
            character(len=80) :: ichr
            character(len=80), save, dimension(2) :: label
cy
            data label/'dofs','error'/
c
c     graph error
c
        ntf=jp(1)
        if(ntf<=0) return
        mpisw=jp(12)
        if(mpisw/=1) return
        nproc=jp(2)
        if(ipix==1) then
            jbeg=3
            jend=4
            icolor(1)=ccolor(2_iknd,0_iknd,jp)
            icolor(2)=ccolor(6_iknd,0_iknd,jp)
        else
            jbeg=1
            jend=2
            icolor(1)=ccolor(3_iknd,0_iknd,jp)
            icolor(2)=ccolor(1_iknd,0_iknd,jp)
        endif
        smx=0.0e0_rknd
        smn=0.0e0_rknd
        s2=log(2.0e0_rknd)
        do j=jbeg,jend
            sr(j)=0.0e0_rknd
            do i=1,nproc
                sr(j)=sr(j)+pstat(j,i)
            enddo
            if(sr(j)<=0.0e0_rknd) return
            sr(j)=real(nproc,rknd)/sr(j)
            do i=1,nproc
                ss=log(pstat(j,i)*sr(j))/s2
                smx=max(smx,ss)
                smn=min(smn,ss)
            enddo
        enddo
c
        call linit(t,q)
        size=t(14)
        xshift=t(15)-size/2.0e0_rknd
        yshift=t(16)-size/2.0e0_rknd
        zshift=t(5)
        t(1)=xshift
        t(2)=yshift
        t(3)=size
        sfact(1)=0.8e0_rknd/sqrt(2.0e0_rknd)
        sfact(2)=0.8e0_rknd
        sfact(3)=0.6e0_rknd
        sfact(4)=0.6e0_rknd
c
c       set up input arrays
c
        h=0.025e0_rknd
        h2=h/2.0e0_rknd
        xl=3.0e0_rknd*h
        xr=1.0e0_rknd-xl
        yl=xl
        yr=xr
        jmin=0
        jmax=jmin+nproc+1
        numx=jmax+1
        imin=int(smn)
        if(smn<real(imin,rknd)) imin=imin-1
        imax=int(smx)
        if(smx>real(imax,rknd)) imax=imax+1
        if(jmax-jmin<=12) then
             ix=1
        else if(jmax-jmin<=40) then
            jmax=jmin+((jmax-jmin-1)/4)*4+4
            numx=(jmax-jmin)/4+1
            ix=4
        else
            ix=((jmax-jmin-1)/100+1)*10
            jmax=jmin+((jmax-jmin-1)/ix)*ix+ix
            numx=(jmax-jmin)/ix+1
        endif
        if(imax-imin<=6) then
            numy=imax-imin+1
            iy=1
        else if(imax-imin<=40) then
            imax=imin+((imax-imin-1)/4)*4+4
            numy=(imax-imin)/4+1
            iy=4
        else
            iy=((imax-imin-1)/100+1)*10
            imax=imin+((imax-imin-1)/iy)*iy+iy
            numy=(imax-imin)/iy+1
        endif
c
c       banner
c
        yyl=yr+1.2e0_rknd*h
        yyr=yyl+h
        ym=yyl+h2
        hx=(xr-xl)/3.5e0_rknd
        do j=1,2
            call fstr(ichr,nchr,label(j),0_iknd)
            ichr(nchr+1:nchr+1)=' '
            xxl=xl+real(j-1,rknd)*hx
            xxr=xxl+real(nchr,rknd)*h
            xxm=xxr+h
            dxm=h
            dym=h
            itype=j+2
            call symbl(xxm,ym,dxm,dym,itype,icolor(j),t)
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
c       axis
c
        call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,ix,numy,imin,iy)
c
c        graph
c
        dx=(xr-xl)/real(jmax-jmin,rknd)
        dy=(yr-yl)/real(imax-imin,rknd)
        do j=jbeg,jend
            itype=j-jbeg+3
            hh=h*sfact(itype)
            ic=2
            if(nproc>64) ic=icolor(j-jbeg+1)
            do i=1,nproc
                xs=xl+dx*real(i,rknd)
                ss=log(pstat(j,i)*sr(j))/s2
                ys=yl+dy*(ss-real(imin,rknd))
                xx=xs*size+xshift
                yy=ys*size+yshift
                if(nproc<=64)
     +              call symbl(xs,ys,hh,hh,itype,icolor(j-jbeg+1),t)
c
                x(2)=xx
                y(2)=yy
                z(2)=zshift
                if(i>1) call pline(x,y,z,2_iknd,ic)
                x(1)=xx
                y(1)=yy
                z(1)=zshift
            enddo
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine timplt(time,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(2) :: icolor,jcolor
            integer(kind=iknd), dimension(50) :: map
            integer(kind=iknd), dimension(10) :: mcic,iptr
            integer(kind=iknd), save, dimension(10) :: order
            real(kind=rknd), dimension(3,*) :: time
            real(kind=rknd), dimension(5) :: x,y,z
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(2,50) :: t0
            character(len=80) :: ichr
            character(len=80), dimension(36) :: name
            character(len=80), save, dimension(2) :: label
            character(len=80), dimension(50) :: name0
            character(len=80), dimension(10) :: lab0
cy
            data label/'last call','accumulated'/
            data order/1,2,3,6,5,4,7,8,9,10/
c
c       print time statistics
c
        call timdat(num0,name0,map,ll,lab0,mcic)
        call linit(t,q)
        mxcolr=jp(17)
        if(mxcolr>=8) then
            icolor(1)=ccolor(6_iknd,0_iknd,jp)
            icolor(2)=ccolor(2_iknd,0_iknd,jp)
            jcolor(1)=icolor(1)
            jcolor(2)=icolor(2)
        else
            icolor(1)=ccolor(mxcolr-2_iknd,0_iknd,jp)
            if(mxcolr==4) then
                icolor(2)=ccolor(1_iknd,0_iknd,jp)
            else
                icolor(2)=ccolor(2_iknd,0_iknd,jp)
            endif
            jcolor(1)=2
            jcolor(2)=2
        endif
        size=t(14)
        zshift=t(5)
        xx=t(15)-size/2.0e0_rknd
        yy=t(16)-size/2.0e0_rknd
c
        do i=1,ll+1
            iptr(i)=0
        enddo
        do i=1,num0
            if(time(2,i)>0.0e0_rknd) then
                 k=order(map(i))+1
                 iptr(k)=iptr(k)+1
            endif
        enddo
        iptr(1)=1
        do i=2,ll+1
            iptr(i)=iptr(i)+iptr(i-1)
        enddo
c
        s1=0.0e0_rknd
        s2=0.0e0_rknd
        do i=1,num0-1
            if(time(2,i)>0.0e0_rknd) then
                k=order(map(i))
                name(iptr(k))=name0(i)
                t0(1,iptr(k))=time(1,i)
                t0(2,iptr(k))=time(2,i)
                s1=s1+time(1,i)
                s2=s2+time(2,i)
                iptr(k)=iptr(k)+1
            endif
        enddo
        do i=ll,2,-1
           iptr(i)=iptr(i-1)
        enddo
        iptr(1)=1
c
        num=iptr(ll+1)
        name(num)=name0(num0)
        t0(1,num)=s1
        t0(2,num)=s2
        if(s2==0.0e0_rknd) return
        ss=1.0e0_rknd/abs(s2)
c
        xxl=xx
        xxr=xx+size
        yyb=yy
        yyt=yy+size
        dx=(xxr-xxl)/4.3e0_rknd
        dy=(yyt-yyb)/(real(num,rknd)+3.75e0_rknd)
        h=size/43.0e0_rknd
        h2=h/2.0e0_rknd
c
c       banner
c
        yl=yyt-dy
        yr=yl+h
        ym=yl+h2
        hx=(xxr-xxl)/4.0e0_rknd
        do j=1,2
            call fstr(ichr,nchr,label(j),0_iknd)
            xl=xxl+real(j-1,rknd)*hx
            xr=xl+real(nchr,rknd)*h
            xm=xr+h2
            call symbl(xm,ym,h,h,1_iknd,icolor(j),t)
            call htext(xl,yl,xr,yr,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
c        horizontal axis
c
        do i=1,5
            z(i)=zshift
        enddo
        x(1)=xxl+2.2e0_rknd*dx
        x(2)=xxr
        x(3)=x(2)
        x(4)=x(1)
        x(5)=x(1)
        y(1)=yyt-(real(num,rknd)+1.75e0_rknd)*dy
        y(2)=y(1)
        y(3)=yyt-1.75e0_rknd*dy
        y(4)=y(3)
        y(5)=y(1)
        call pline(x,y,z,5_iknd,2_iknd)
        dd=(xxr-xxl-2.2e0_rknd*dx)/5.0e0_rknd
        do i=1,6
            k=(i-1)*20
            call sint(ichr,nchr,k)
            x(1)=xxl+2.2e0_rknd*dx+real(i-1,rknd)*dd
            x(2)=x(1)
            y(1)=yyt-(real(num,rknd)+1.75e0_rknd)*dy
            y(2)=y(1)-0.02e0_rknd*size
            call pline(x,y,z,2_iknd,2_iknd)
            xl=x(1)-real(nchr,rknd)*h/2.0e0_rknd
            xr=x(1)+real(nchr,rknd)*h/2.0e0_rknd
            yl=y(2)-2.0e0_rknd*h
            yr=y(2)-h
            call htext(xl,yl,xr,yr,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
        do i=1,num
c
c       names
c
            call fstr(ichr,nchr,name(i),0_iknd)
            xl=xxl
            xr=xl+0.6e0_rknd*dx
            yl=yyt-real(i+1,rknd)*dy-0.75e0_rknd*dy
            yr=yl+h
            call htext(xl,yl,xr,yr,6_iknd,ichr,-1_iknd,q,t,2_iknd)
            if(max(t0(1,i),t0(2,i))<=0.0e0_rknd) cycle
c
c       times
c
            do k=1,2
                xl=xr+0.05e0_rknd*dx
                xr=xl+0.7e0_rknd*dx
                if(t0(k,i)<=0.0e0_rknd) cycle
                ichr=' '
                if(t0(k,i)>10.0e0_rknd) then
                   ii=int(log10(t0(k,i)))+2
                else
                   ii=2
                endif
                call sfix(ichr(6:6),nchr,t0(k,i),ii)
                if(nchr<8) then
                    ii=nchr-2
                    nchr=8
                else
                    ii=6
                endif
                call htext(xl,yl,xr,yr,nchr,ichr(ii:ii),
     +              1_iknd,q,t,jcolor(k))
            enddo
c
c        histogram
c
            do k=2,1,-1
                if(t0(k,i)>0.0e0_rknd) then
                    xp=xr+0.1e0_rknd*dx
                    if(k==1) then
                        x(1)=xp
                    else
                        x(1)=xp+t0(k-1,i)*(xxr-xp)*ss
                    endif
                    x(2)=xp+t0(k,i)*(xxr-xp)*ss
                    x(3)=x(2)
                    x(4)=x(1)
                    x(5)=x(1)
                    y(1)=yl
                    y(2)=y(1)
                    y(3)=yl+dy
                    y(4)=y(3)
                    y(5)=y(1)
                    call pfill(x,y,z,4_iknd,icolor(k))
                    call pline(x,y,z,5_iknd,2_iknd)
                endif
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine timpl0(time,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(50) :: icolor,map
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(10) :: mcic
            integer(kind=iknd), dimension(8) :: iptr
            integer(kind=iknd), save, dimension(7) :: order
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(3,*) :: time
            real(kind=rknd), dimension(50) :: tim1,tim2
            character(len=80) :: ichr
            character(len=80), dimension(10) :: label
            character(len=80), dimension(50) :: name,name0
cy
            data order/1,2,3,6,5,4,7/
c
c     graph times
c
        call timdat(len0,name0,map,num,label,mcic)
        len0=len0-1
        call linit(t,q)
        size=t(14)
        xshift=t(15)-size/2.0e0_rknd
        yshift=t(16)-size/2.0e0_rknd
        t(1)=xshift
        t(2)=yshift
        t(3)=size
c
c       set up input arrays
c
        do i=1,num+1
            iptr(i)=0
        enddo
        do i=1,len0
            if(time(2,i)>0.0e0_rknd) then
                k=order(map(i))+1
                iptr(k)=iptr(k)+1
            endif
        enddo
        iptr(1)=1
        do i=2,num+1
            iptr(i)=iptr(i)+iptr(i-1)
        enddo
        tot2=0.0e0_rknd
        tot1=0.0e0_rknd
        do i=1,len0
            if(time(2,i)>0.0e0_rknd) then
                k=order(map(i))
                name(iptr(k))=name0(i)
                tim1(iptr(k))=time(1,i)
                tim2(iptr(k))=time(2,i)
                icolor(iptr(k))=ccolor(mcic(map(i)),0_iknd,jp)
                tot1=tot1+time(1,i)
                tot2=tot2+time(2,i)
                iptr(k)=iptr(k)+1
            endif
        enddo
        do i=num,2,-1
           iptr(i)=iptr(i-1)
        enddo
        iptr(1)=1
        len=iptr(num+1)
        name(len)=name0(len0+1)
        icolor(len)=2
        tim1(len)=tot1
        tim2(len)=tot2
        if(tot2<=0.0e0_rknd) return
c
        xl=t(15)-size/2.0e0_rknd
        yt=t(16)+size/2.0e0_rknd
        hf=max(24.0e0_rknd,real(len+10,rknd))
        h=size/hf
        ss=min(hf/real(len+1,rknd),4.0e0_rknd)
        dx=(size-4.0e0_rknd*h)/5.0e0_rknd
        do i=1,len
            yyl=yt-h*real(i,rknd)*ss
            yyr=yyl+h
            xm=xl+h/2.0e0_rknd
            ym=yyl+h/2.0e0_rknd
            call symbl(xm,ym,h,h,1_iknd,icolor(i),t)
            call fstr(ichr,nchr,name(i),0_iknd)
            xxl=xl+h*1.5e0_rknd
            xxr=xxl+dx
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +          -1_iknd,q,t,2_iknd)
c
            tm=tim1(i)
            if(tm>0.0e0_rknd) then
                k=2
                if(tm>10.0e0_rknd) k=int(log10(tm))+2
                call sfix(ichr,nchr,tm,k)
                xxl=xxr+h
                xxr=xxr+dx
                call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +              1_iknd,q,t,2_iknd)
c
                fr=tim1(i)/tot2*100.0e0_rknd
                k=1
                if(fr>=10.0e0_rknd) k=2
                call sfix(ichr,nchr,fr,k)
                xxl=xxr+h
                xxr=xxr+dx
                call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +              1_iknd,q,t,2_iknd)
            else
                xxr=xxr+2.0e0_rknd*dx
            endif
c
            tm=tim2(i)
            k=2
            if(tm>10.0e0_rknd) k=int(log10(tm))+2
            call sfix(ichr,nchr,tm,k)
            xxl=xxr+h
            xxr=xxr+dx
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +          1_iknd,q,t,2_iknd)
c
            fr=tim2(i)/tot2*100.0e0_rknd
            k=1
            if(fr>=10.0e0_rknd) k=2
            call sfix(ichr,nchr,fr,k)
            xxl=xxr+h
            xxr=xxr+dx
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +          1_iknd,q,t,2_iknd)
c
            xm=xxr+h*1.5e0_rknd
            ym=yyl+h/2.0e0_rknd
            call symbl(xm,ym,h,h,1_iknd,icolor(i),t)
c
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pieplt(time,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(20) :: icolor
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(50) :: map
            integer(kind=iknd), dimension(10) :: mcic
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(3,*) :: time
            real(kind=rknd), dimension(21) :: th
            real(kind=rknd), dimension(20) :: dt,tim
            real(kind=rknd), dimension(90) :: x,y,z
            character(len=80) :: ichr
            character(len=80), dimension(10) :: label
            character(len=80), dimension(50) :: name
cy
c     graph times
c
        call timdat(len,name,map,num,label,mcic)
        len=len-1
        call linit(t,q)
        size=t(14)
        xshift=t(15)-size/2.0e0_rknd
        yshift=t(16)-size/2.0e0_rknd
        t(1)=xshift
        t(2)=yshift
        t(3)=size
        zshift=t(5)
        scale=t(3)
c
c       set up input arrays
c
        do i=1,num
            icolor(i)=ccolor(mcic(i),0_iknd,jp)
            tim(i)=0.0e0_rknd
        enddo
        do i=1,len
            tim(map(i))=tim(map(i))+time(2,i)
        enddo
        tot=0.0e0_rknd
        do i=1,num
            tot=tot+tim(i)
        enddo
        if(tot<=0.0e0_rknd) return
        pi=3.141592653589793e0_rknd
        th(1)=pi/2.0e0_rknd
        do i=1,num
            fr=tim(i)/tot
            dt(i)=fr*2.0e0_rknd*pi
            th(i+1)=th(i)+dt(i)
        enddo
c
c       make pie chart
c
        xcen=0.5e0_rknd
        ycen=0.4e0_rknd
        rad=0.35e0_rknd
        dd=pi/32.0e0_rknd
        do i=1,num
            m=int(dt(i)/dd)
            x(1)=xcen*scale+xshift
            y(1)=ycen*scale+yshift
            z(1)=zshift
            dtheta=dt(i)/real(m+1,rknd)
            theta=th(i)
            do j=1,m+2
                ang=theta+dtheta*real(j-1,rknd)
                xx=xcen+rad*cos(ang)
                yy=ycen+rad*sin(ang)
                x(j+1)=xx*scale+xshift
                y(j+1)=yy*scale+yshift
                z(j+1)=zshift
            enddo
            x(m+4)=x(1)
            y(m+4)=y(1)
            z(m+4)=z(1)
            call pfill(x,y,z,m+3_iknd,icolor(i))
            call pline(x,y,z,m+4_iknd,2_iknd)
        enddo
c
        xl=t(15)-size/2.0e0_rknd
        yt=t(16)+size/2.0e0_rknd
        h=size/30.0e0_rknd
        h=size/27.0e0_rknd
        mm=num/2
        do i=1,mm
            yyl=yt-h*real(i,rknd)*1.5e0_rknd
            yyr=yyl+h
            xs=xl
            xr=t(15)
            ii=i
            do j=1,2
                xm=xs
                ym=yyl+h/2.0e0_rknd
                call symbl(xm,ym,h,h,1_iknd,icolor(ii),t)
                call fstr(ichr,nchr,label(ii),0_iknd)
                xxl=xs+h
                xxr=xxl+real(nchr,rknd)*h
                call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +              -1_iknd,q,t,2_iknd)
                fr=tim(ii)/tot*100.0e0_rknd
                k=1
                if(fr>=10.0e0_rknd) k=2
                call sfix(ichr,nchr,fr,k)
                xxr=xr-h
                if(j==2) xxr=xr
                xxl=xxr-real(nchr,rknd)*h
                call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +              1_iknd,q,t,2_iknd)
                xs=t(15)+h
                xr=t(15)+size/2.0e0_rknd
                ii=num+1-i
           enddo
        enddo
c
        label(num+1)='total time -- '
        call fstr(ichr,nchr,label(num+1),0_iknd)
        xxl=xl+h
        xxr=xxl+real(nchr,rknd)*h
        yyl=yt
        yyr=yyl+h
        call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +      -1_iknd,q,t,2_iknd)
        k=2
        if(tot>10.0e0_rknd) k=int(log10(tot))+2
        call sfix(ichr,nchr,tot,k)
        ichr(nchr+1:nchr+8)=' seconds'
        xxl=t(15)
        xxr=xxl+real(nchr+8,rknd)*h
        call htext(xxl,yyl,xxr,yyr,nchr+8_iknd,ichr,
     +      -1_iknd,q,t,2_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine subplt(time,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(50) :: icolor,map
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(10) :: mcic
            integer(kind=iknd), dimension(7) :: iptr
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(3,*) :: time
            real(kind=rknd), dimension(50) :: tim
            character(len=80) :: ichr,nn
            character(len=80), dimension(10) :: label
            character(len=80), dimension(50) :: name,name0
cy
c     graph times
c
        call timdat(len0,name0,map,num,label,mcic)
        len0=len0-1
        call linit(t,q)
        size=t(14)
        xshift=t(15)-size/2.0e0_rknd
        yshift=t(16)-size/2.0e0_rknd
        t(1)=xshift
        t(2)=yshift
        t(3)=size
c
c       set up input arrays
c
        do i=1,num+1
            iptr(i)=0
        enddo
        do i=1,len0
            if(time(2,i)>0.0e0_rknd) iptr(map(i)+1)=iptr(map(i)+1)+1
        enddo
        iptr(1)=1
        do i=2,num+1
            iptr(i)=iptr(i)+iptr(i-1)
        enddo
        tot=0.0e0_rknd
        do i=1,len0
            if(time(2,i)>0.0e0_rknd) then
                k=map(i)
                name(iptr(k))=name0(i)
                tim(iptr(k))=time(2,i)
                icolor(iptr(k))=ccolor(mcic(k),0_iknd,jp)
                tot=tot+time(2,i)
                iptr(k)=iptr(k)+1
            endif
        enddo
        do i=num,2,-1
           iptr(i)=iptr(i-1)
        enddo
        iptr(1)=1
        if(tot<=0.0e0_rknd) return
c
        mm=num/2
        do m=mm+1,num
            ii=(iptr(m+1)-iptr(m))/2
            do i=1,ii
                i1=i+iptr(m)-1
                i2=iptr(m+1)-i
                nn=name(i1)
                name(i1)=name(i2)
                name(i2)=nn
                tt=tim(i1)
                tim(i1)=tim(i2)
                tim(i2)=tt
            enddo
        enddo
        xl=t(15)-size/2.0e0_rknd
        yt=t(16)+size/2.0e0_rknd
        hf=24.0e0_rknd
        h=size/hf
        mrt=iptr(mm+1)-iptr(1)
        mlt=iptr(num+1)-iptr(mm+1)
        mx=max(mrt,mlt)
        ss=min(hf/real(mx+1,rknd),4.0e0_rknd)
        do i=1,mx
            yyl=yt-h*real(i,rknd)*ss
            yyr=yyl+h
            xr=t(15)
            xs=xl
            ii=i
            if(i>=iptr(mm+1)) ii=0
            do j=1,2
                if(ii>0) then
                    xm=xs
                    ym=yyl+h/2.0e0_rknd
                    call symbl(xm,ym,h,h,1_iknd,icolor(ii),t)
                    call fstr(ichr,nchr,name(ii),0_iknd)
                    xxl=xs+h
                    xxr=xxl+real(nchr,rknd)*h
                    call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +                  -1_iknd,q,t,2_iknd)
                    fr=tim(ii)/tot*100.0e0_rknd
                    k=1
                    if(fr>=10.0e0_rknd) k=2
                    call sfix(ichr,nchr,fr,k)
                    xxr=xr-h
                    if(j==2) xxr=xr
                    xxl=xxr-real(nchr,rknd)*h
                    call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +                  1_iknd,q,t,2_iknd)
                endif
                xs=t(15)+h
                xr=t(15)+size/2.0e0_rknd
                ii=iptr(num+1)-i
                if(ii<iptr(mm+1)) ii=0
           enddo
c
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine aveplt(ptime,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(4) :: sfact
            real(kind=rknd), dimension(10) :: x,y,z
            real(kind=rknd), dimension(*) :: ptime
            character(len=80) :: ichr
cy
c     graph error
c
        ntf=jp(1)
        if(ntf<=0) return
        nproc=jp(2)
        tmx=ptime(1)
        tmn=ptime(1)
        ave=0.0e0_rknd
        do i=1,nproc
            tmx=max(tmx,ptime(i))
            tmn=min(tmn,ptime(i))
            ave=ave+ptime(i)
        enddo
        if(ave<=0.0e0_rknd) return
        ave=real(nproc,rknd)/ave
        smx=0.0e0_rknd
        smn=0.0e0_rknd
        s2=log(2.0e0_rknd)
        do i=1,nproc
            ss=log(ptime(i)*ave)/s2
            smx=max(smx,ss)
            smn=min(smn,ss)
        enddo
c
        call linit(t,q)
        size=t(14)
        xshift=t(15)-size/2.0e0_rknd
        yshift=t(16)-size/2.0e0_rknd
        zshift=t(5)
        t(1)=xshift
        t(2)=yshift
        t(3)=size
        sfact(1)=0.8e0_rknd/sqrt(2.0e0_rknd)
        sfact(2)=0.8e0_rknd
        sfact(3)=0.6e0_rknd
        sfact(4)=0.6e0_rknd
        icolor=ccolor(6_iknd,0_iknd,jp)
c
c       set up input arrays
c
        h=0.025e0_rknd
        xl=3.0e0_rknd*h
        xr=1.0e0_rknd-xl
        yl=xl
        yr=xr
        jmin=0
        jmax=jmin+nproc+1
        numx=jmax+1
        imin=int(smn)
        if(smn<real(imin,rknd)) imin=imin-1
        imax=int(smx)
        if(smx>real(imax,rknd)) imax=imax+1
        if(jmax-jmin<=12) then
             ix=1
        else if(jmax-jmin<=40) then
            jmax=jmin+((jmax-jmin-1)/4)*4+4
            numx=(jmax-jmin)/4+1
            ix=4
        else
            ix=((jmax-jmin-1)/100+1)*10
            jmax=jmin+((jmax-jmin-1)/ix)*ix+ix
            numx=(jmax-jmin)/ix+1
        endif
        if(imax-imin<=6) then
            numy=imax-imin+1
            iy=1
        else if(imax-imin<=40) then
            imax=imin+((imax-imin-1)/4)*4+4
            numy=(imax-imin)/4+1
            iy=4
        else
            iy=((imax-imin-1)/100+1)*10
            imax=imin+((imax-imin-1)/iy)*iy+iy
            numy=(imax-imin)/iy+1
        endif
c
c       banner
c
        yyl=yr+1.2e0_rknd*h
        yyr=yyl+h
        xxl=xl
        ichr(1:4)='min '
        val=tmn
        do j=1,2
            if(val>10.0e0_rknd) then
               ii=int(log10(val))+2
            else
               ii=2
            endif
            call sfix(ichr(5:5),nchr,val,ii)
            nchr=nchr+4
            xxr=xxl+real(nchr,rknd)*h
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,
     +          -1_iknd,q,t,2_iknd)
            xxl=(xl+xr)/2.0e0_rknd
            ichr(1:4)='max '
            val=tmx
        enddo
c
c       axis
c
        call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,ix,numy,imin,iy)
c
c       graph
c
        dx=(xr-xl)/real(jmax-jmin,rknd)
        dy=(yr-yl)/real(imax-imin,rknd)
        itype=2
        hh=h*sfact(itype)
        do i=1,nproc
            xs=xl+dx*real(i,rknd)
            ss=log(ptime(i)*ave)/s2
            ys=yl+dy*(ss-real(imin,rknd))
            xx=xs*size+xshift
            yy=ys*size+yshift
            call symbl(xs,ys,hh,hh,itype,icolor,t)
c
            x(2)=xx
            y(2)=yy
            z(2)=zshift
            if(i>1) call pline(x,y,z,2_iknd,2_iknd)
            x(1)=xx
            y(1)=yy
            z(1)=zshift
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine timdat(num0,name0,jcat,len0,label0,color0)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save, dimension(50) :: icat
            integer(kind=iknd), dimension(*) :: jcat,color0
            integer(kind=iknd), save, dimension(10) :: color
            integer(kind=iknd), save :: num,len
            character(len=80), dimension(*) :: name0,label0
            character(len=80), save, dimension(10) :: label
            character(len=80), save, dimension(50) :: name
cy
            data num/36/
            data name( 1),icat( 1)/'tgen  ',2/
            data name( 2),icat( 2)/'refine',2/
            data name( 3),icat( 3)/'unrefn',2/
            data name( 4),icat( 4)/'hunfrm',2/
            data name( 5),icat( 5)/'punfrm',2/
            data name( 6),icat( 6)/'mvemsh',2/
            data name( 7),icat( 7)/'errest',1/
            data name( 8),icat( 8)/'cbump ',1/
            data name( 9),icat( 9)/'cdlfn ',1/
            data name(10),icat(10)/'expth ',3/
            data name(11),icat(11)/'exflag',3/
            data name(12),icat(12)/'bcast ',3/
            data name(13),icat(13)/'ldbal ',3/
            data name(14),icat(14)/'lbev  ',3/
            data name(15),icat(15)/'cutr  ',3/
            data name(16),icat(16)/'paste ',3/
            data name(17),icat(17)/'paste1',3/
            data name(18),icat(18)/'trigen',2/
c
            data name(19),icat(19)/'setgrb',5/
            data name(20),icat(20)/'setgr2',5/
            data name(21),icat(21)/'ja2ja ',5/
            data name(22),icat(22)/'sfbilu',5/
            data name(23),icat(23)/'sfhb  ',5/
            data name(24),icat(24)/'mg    ',5/
            data name(25),icat(25)/'blk3  ',5/
            data name(26),icat(26)/'blk4  ',5/
            data name(27),icat(27)/'blk5  ',5/
            data name(28),icat(28)/'linsys',6/
            data name(29),icat(29)/'rgnsys',6/
            data name(30),icat(30)/'cev   ',4/
            data name(31),icat(31)/'swbrch',4/
            data name(32),icat(32)/'predct',4/
            data name(33),icat(33)/'tpick ',4/
            data name(34),icat(34)/'tpickd',4/
            data name(35),icat(35)/'pltmg ',4/
c
            data name(36),icat(36)/'total ',7/
c
            data len/6/
            data label(1),color(1)/'errors',3/
            data label(2),color(2)/'mesh gen', 1/
            data label(3),color(3)/'parallel', 5/
            data label(4),color(4)/'pltmg', 2/
            data label(5),color(5)/'m-graph', 4/
            data label(6),color(6)/'assembly', 6/
c
        num0=num
        do i=1,num
            name0(i)=name(i)
            jcat(i)=icat(i)
        enddo
        len0=len
        do i=1,len
            label0(i)=label(i)
            color0(i)=color(i)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine errplt(hist,igraph,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(22) :: ic
            integer(kind=iknd), save, dimension(6) :: icc
            integer(kind=iknd) :: ccolor
            real(kind=rknd), dimension(22) :: rn,e,w
            real(kind=rknd), dimension(25) :: t,x,y,z,xn,yn,zn
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(22,*) :: hist
            character(len=80) :: ichr
            character(len=80), save, dimension(4) :: label
cy
            data label/'error in h1 norm','error in l2 norm',
     +                 'error in lambda ','error in rho    '/
            data icc/3,4,2,1,6,5/
c
c       initialize
c
        mxhist=20
        call linit(t,q)
        size=t(14)
        xx=t(15)-size/2.0e0_rknd
        yy=t(16)-size/2.0e0_rknd
        t(1)=xx
        t(2)=yy
        t(3)=size
        mpisw=jp(12)
        ishift=0
        if(mpisw==1) ishift=18
c
        num=int(hist(mxhist+2,ishift+1))
        if(num<=0) return
c
c       set up input arrays
c
        e1=abs(hist(mxhist+2,ishift+igraph+2))
        if(e1>0.0e0_rknd) e1=1.0e0_rknd/e1
        do i=1,num
            rn(i)=log10(hist(i,ishift+1))
            w(i)=log10(hist(i,ishift+5))
            e(i)=0.0e0_rknd
            qq=abs(hist(i,ishift+igraph+2))*e1
            if(qq>0.0e0_rknd) e(i)=log10(qq)
            ii=int(hist(i,ishift+2))+2
            if(ii<1) ii=1
            if(ii>6) ii=6
            if(mpisw==1) ii=2
            ic(i)=ccolor(icc(ii),0_iknd,jp)
        enddo
c
        wmx=w(1)
        wmn=w(1)
        rmx=rn(1)
        emx=e(1)
        emn=emx
        do i=1,num
            rmx=max(rn(i),rmx)
            wmx=max(w(i),wmx)
            wmn=min(w(i),wmn)
            emx=max(e(i),emx)
            emn=min(e(i),emn)
        enddo
c
        numx=max(5,int(rmx)+2)
c
        iminy=int(wmn)
        if(wmn<real(iminy,rknd)) iminy=iminy-1
        imaxy=int(wmx)
        if(wmx>real(imaxy,rknd)) imaxy=imaxy+1
        if(imaxy-iminy<4) then
            iminy=iminy-(4+iminy-imaxy)/2
            imaxy=iminy+4
        endif
        numy=imaxy-iminy+1
c
        iminz=int(emn)
        if(emn<real(iminz,rknd)) iminz=iminz-1
        imaxz=int(emx)
        if(emx>real(imaxz,rknd)) imaxz=imaxz+1
        if(imaxz-iminz<4) then
            iminz=iminz-(4+iminz-imaxz)/2
            imaxz=iminz+4
        endif
        numz=imaxz-iminz+1
c
        h=0.025e0_rknd
        xl=3.0e0_rknd*h
        xr=1.0e0_rknd-xl
        yl=xl
        yr=xr
        zl=xl
        zr=xr
c
c       banners
c
        call fstr(ichr,nchr,label(igraph),0_iknd)
        xxl=0.0e0_rknd
        xxr=1.0e0_rknd
        yyl=1.0e0_rknd-h
        yyr=1.0e0_rknd
        call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
c
c       set up rotated coordinate system
c
        call mkrot(jp(13),jp(14),jp(15),q)
c
        xmin=min(0.0e0_rknd,q(1,1))+min(0.0e0_rknd,q(2,1))
        xmax=max(0.0e0_rknd,q(1,1))+max(0.0e0_rknd,q(2,1))
        ymin=min(0.0e0_rknd,q(1,2))+min(0.0e0_rknd,q(2,2))
        ymax=max(0.0e0_rknd,q(1,2))+max(0.0e0_rknd,q(2,2))+q(3,2)
        zmin=min(0.0e0_rknd,q(1,3))
     +      +min(0.0e0_rknd,q(2,3))
     1      +min(0.0e0_rknd,q(3,3))
        zmax=max(0.0e0_rknd,q(1,3))
     +      +max(0.0e0_rknd,q(2,3))
     1      +max(0.0e0_rknd,q(3,3))
c
        scale=size/max(xmax-xmin,ymax-ymin)
        xshift=xx+(size-scale*(xmax+xmin))/2.0e0_rknd
        yshift=yy+(size-scale*(ymax+ymin))/2.0e0_rknd
        zshift=   (size-scale*(zmax+zmin))/2.0e0_rknd
        t(1)=xshift
        t(2)=yshift
        t(5)=zshift
        t(3)=scale
c
        dx=(xr-xl)/real(numx-1,rknd)
        dz=(zr-zl)/real(numz-1,rknd)
        dy=(yr-yl)/real(numy-1,rknd)
        do i=1,num
            x(i)=xl+dx*rn(i)
            y(i)=yl+dy*(w(i)-real(iminy,rknd))
            z(i)=zl+dz*(e(i)-real(iminz,rknd))
            xn(i)=(x(i)*q(1,1)+y(i)*q(2,1))*scale+xshift
            yn(i)=(x(i)*q(1,2)+y(i)*q(2,2)+z(i)*q(3,2))*scale+yshift
            zn(i)=(x(i)*q(1,3)+y(i)*q(2,3)+z(i)*q(3,3))*scale+zshift
        enddo
c
c       we must call routines in right order to get the
c       hidden lines right
c
        if(q(3,3)>0.0e0_rknd) then
            call xygrid(xl,xr,yl,yr,zl,h,t,q,
     +          numx,0_iknd,1_iknd,numy,0_iknd,4_iknd)
        else
            call pline(xn,yn,zn,num,2_iknd)
        endif
        isw=1
        if(q(2,3)<0.0e0_rknd) then
            do i=num,1,-1
                call cbox(x(i),y(i),z(i),zl,h,t,q,ic(i),isw)
            enddo
            call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1_iknd)
         else
            call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1_iknd)
            do i=1,num
                call cbox(x(i),y(i),z(i),zl,h,t,q,ic(i),isw)
            enddo
        endif
        if(q(3,3)<=0.0e0_rknd) then
            call xygrid(xl,xr,yl,yr,zl,h,t,q,
     +          numx,0_iknd,1_iknd,numy,0_iknd,4_iknd)
        else
            call pline(xn,yn,zn,num,2_iknd)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine nwtplt(hist,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(2) :: icolor
            integer(kind=iknd) :: ccolor
            real(kind=rknd), dimension(22,2) :: e
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(22,*) :: hist
            character(len=80) :: ichr
            character(len=80), save, dimension(6) :: label
cy
            data label/'newton residual ','newton increment',
     +                 'upper bound     ','lower bound     ',
     +                 'dd newton residual','dd newton increment'/
c
c     graph error
c
        call linit(t,q)
        size=t(14)
        xshift=t(15)-size/2.0e0_rknd
        yshift=t(16)-size/2.0e0_rknd
        mxhist=20
        t(1)=xshift
        t(2)=yshift
        t(3)=size
c
        lab1=int(hist(mxhist+1,2))
        if(lab1==-1) then
            lab=5
            icolor(1)=ccolor(1_iknd,0_iknd,jp)
            icolor(2)=ccolor(3_iknd,0_iknd,jp)
        else if(lab1==-2) then
            lab=3
            icolor(1)=ccolor(4_iknd,0_iknd,jp)
            icolor(2)=ccolor(5_iknd,0_iknd,jp)
        else
            lab=1
            icolor(1)=ccolor(6_iknd,0_iknd,jp)
            icolor(2)=ccolor(2_iknd,0_iknd,jp)
        endif
        num1=int(hist(mxhist+1,1))
        num=min(num1,mxhist)
        if(num<=0) return
        do j=1,2
            e1=abs(hist(mxhist+2,j))
            if(e1>0.0e0_rknd) e1=1.0e0_rknd/e1
            do i=1,num
                qq=abs(hist(i,j))*e1
                e(i,j)=0.0e0_rknd
                if(qq>0.0e0_rknd) e(i,j)=log10(qq)
            enddo
        enddo
c
        h=0.025e0_rknd
        h2=h/2.0e0_rknd
        xl=3.0e0_rknd*h
        xr=1.0e0_rknd-xl
        yl=xl
        yr=xr
        jmin=max(num1-mxhist,0)
        jmax=jmin+max(((num1-jmin-1)/4)*4+4,8)
        if(jmax-jmin==8) then
            numx=5
            is=2
        else if(jmax-jmin<=40) then
            numx=(jmax-jmin)/4+1
            is=4
        else
            jmax=jmin+((num1-jmin-1)/10)*10+10
            numx=(jmax-jmin)/10+1
            is=10
        endif
        emx=e(1,1)
        emn=emx
        do i=1,num
            emx=max(e(i,1),e(i,2),emx)
            emn=min(e(i,1),e(i,2),emn)
        enddo
        imin=int(emn)
        if(emn<real(imin,rknd)) imin=imin-1
        imax=int(emx)
        if(emx>real(imax,rknd)) imax=imax+1
        if(imax-imin<4) then
            imin=imin-(4+imin-imax)/2
            imax=imin+4
        endif
        numy=imax-imin+1
c
c       banner
c
        yyl=yr+1.8e0_rknd*h
        yyr=yyl+h
        ym=yyl+h2
        xxl=xl-2.0e0_rknd*h
        do j=1,2
            call fstr(ichr,nchr,label(lab+j-1),0_iknd)
            xxr=xxl+real(nchr,rknd)*h
            xm=xxr+h2
            call symbl(xm,ym,h,h,1_iknd,icolor(j),t)
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
            xxl=(xl+xr)/2.0e0_rknd
        enddo
c
c       axis
c
        call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,
     +      is,numy,imin,1_iknd)
c
c        graph
c
        dx=(xr-xl)/real(jmax-jmin,rknd)
        hx=dx/4.0e0_rknd
        dy=(yr-yl)/real(numy-1,rknd)
        do i=1,num
            xs=xl+dx*real(i,rknd)-hx/2.0e0_rknd
            do j=1,2
                xm=xs+real(j-1,rknd)*hx
                hy=dy*(e(i,j)-real(imin,rknd))
                ym=yl+hy/2.0e0_rknd
                call symbl(xm,ym,hx,hy,1_iknd,icolor(j),t)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine kaplt(ip,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(6) :: icolor
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(100) :: ip
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(20) :: ratio
            real(kind=rknd), dimension(2) :: x,y,z
            character(len=80) :: ichr
            character(len=80), save, dimension(5) :: label
cy
            data label/'matrix','ilu','hb','diag','lu'/
c
c     graph storage
c
        nb=ip(91)
        if(nb<=0) return
        ndf=ip(90)
        method=ip(9)
c
        do i=1,3
           do j=1,3
                q(i,j)=0.0e0_rknd
           enddo
           q(i,i)=1.0e0_rknd
        enddo
        call linit(t,q)
c
        size=t(14)
        xshift=t(15)-size/2.0e0_rknd
        yshift=t(16)-size/2.0e0_rknd
        t(1)=xshift
        t(2)=yshift
        t(3)=size
        zshift=t(5)
c
        num=5
        icolor(1)=ccolor(5_iknd,0_iknd,jp)
        icolor(2)=ccolor(4_iknd,0_iknd,jp)
        icolor(3)=ccolor(3_iknd,0_iknd,jp)
        icolor(4)=ccolor(2_iknd,0_iknd,jp)
        icolor(5)=ccolor(1_iknd,0_iknd,jp)
        icolor(6)=1
c
c       set up input arrays
c
        lenja=ip(92)
        lenad=ip(93)
        lenju=ip(97)
        lenju0=ip(95)
        lenjuc=ip(100)
        ispd=ip(8)
c
        lena=ip(93)+ip(94)
        lenu=ip(93)+ip(98)
        lenhb=lenjuc
        lenu0=ip(93)+ip(96)
c
        lenax=lena*2-ndf
        lenadx=lenad*2-ndf
        lenux=lenu*2-ndf
        lenhbx=lenjuc*2 -(nb+1)
        lenu0x=lenu0*2-ndf
c
        if(ispd/=1) then
            lena=lenax
            lenad=lenadx
            lenu=lenux
            lenhb=lenhbx
            lenu0=lenu0x
        endif
c
        if(method/=0) then
              lenhb=0
              lenhbx=0
              lenjuc=0
        endif
        if(method/=1) then
              lenu=0
              lenux=0
              lenju=0
        endif
        if(method==1) then
              lenad=0
              lenadx=0
        endif
c
        ratio(1)=real(lenax,rknd)/real(ndf,rknd)
        ratio(2)=real(lenux,rknd)/real(ndf,rknd)
        ratio(3)=real(lenhbx,rknd)/real(ndf,rknd)
        ratio(4)=real(lenadx,rknd)/real(ndf,rknd)
        ratio(5)=real(lenu0x,rknd)/real(ndf,rknd)
c
        ratio(6)=real(lena,rknd)/real(lenu0,rknd)
        ratio(7)=real(lenu,rknd)/real(lenu0,rknd)
        ratio(8)=real(lenhb,rknd)/real(lenu0,rknd)
        ratio(9)=real(lenad,rknd)/real(lenu0,rknd)
        ratio(10)=1.0e0_rknd
c
        ratio(11)=real(lenja,rknd)/real(lenu0,rknd)
        ratio(12)=real(lenju,rknd)/real(lenu0,rknd)
        ratio(13)=real(lenjuc,rknd)/real(lenu0,rknd)
        ratio(14)=real(lenad,rknd)/real(lenu0,rknd)
        ratio(15)=real(lenju0,rknd)/real(lenu0,rknd)
c
        xl=t(15)-size/2.0e0_rknd
        yt=t(16)+size/2.0e0_rknd
        h=1.0e0_rknd/20.0e0_rknd
        h2=h/2.0e0_rknd
        yyl=yt
        do i=1,num
cc          yyl=yt-h*real(i,rknd)*2.0e0_rknd
            if(ratio(i)==0.0e0_rknd) cycle
            xxl=xl
            yyl=yyl-h*2.0e0_rknd
            xm=xxl+h
            ym=yyl+h2
            call symbl(xm,ym,h,h,1_iknd,icolor(i),t)
c
            call fstr(ichr,nchr,label(i),0_iknd)
            xxl=xl+3.0e0_rknd*h
            xxr=xxl+real(nchr,rknd)*h
            yyr=yyl+h
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1_iknd,q,t,2_iknd)
            ii=3
            if(ratio(i)>=10.0e0_rknd) ii=4
            if(ratio(i)>=100.0e0_rknd) ii=5
            call sreal(ichr,nchr,ratio(i),ii,0_iknd)
            xxl=xl+8.0e0_rknd*h
            xxr=xl+14.0e0_rknd*h
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,1_iknd,q,t,2_iknd)
            fr=ratio(i+num)*100.0e0_rknd
            call sreal(ichr,nchr,fr,3_iknd,0_iknd)
            xxl=xl+15.0e0_rknd*h
            xxr=xl+19.0e0_rknd*h
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,1_iknd,q,t,2_iknd)
        enddo
c
c
        h=0.025e0_rknd
        xl=3.0e0_rknd*h
        xr=1.0e0_rknd-xl
        yl=xl
        yr=xl+size/2.0e0_rknd
c
c       bar graph
c
        hy=size/10.0e0_rknd
        ym=yl-hy/2.0e0_rknd
        do i=num,1,-1
cc          ym=yl+hy*real(9-2*i,rknd)/2.0e0_rknd
            if(ratio(5+i)==0.0e0_rknd) cycle
            ym=ym+hy
            hx=(xr-xl)*ratio(5+i)
            xm=xl+hx/2.0e0_rknd
            call symbl(xm,ym,hx,hy,1_iknd,icolor(i),t)
            z(1)=zshift
            z(2)=z(1)
            x(1)=(xl+(xr-xl)*ratio(10+i))*size+xshift
            x(2)=x(1)
            y(1)=(ym-hy/2.0e0_rknd)*size+yshift
            y(2)=(ym+hy/2.0e0_rknd)*size+yshift
            call pline(x,y,z,2_iknd,2_iknd)
        enddo
c
c       axis
c
        numx=5
        numy=0
        ix=25
        jmin=0
        imin=0
        iy=0
        call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,ix,numy,imin,iy)
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine hbplt(hist,numhst,lab,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(22,4) :: icolor
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(4) :: num1,num
            integer(kind=iknd), dimension(2,4) :: jc
            integer(kind=iknd) :: ccolor
            real(kind=rknd), dimension(22,4) :: e
            real(kind=rknd), dimension(22,*) :: hist
            real(kind=rknd), dimension(25) :: t,x,y,z
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(4) :: ave,sfact
            character(len=80) :: ichr
            character(len=80), save, dimension(3) :: rate
cy
            data rate/'linear systems','singular vector',
     +          'spectral bisection'/
c
c     graph error
c
        call linit(t,q)
        size=t(14)
        xshift=t(15)-size/2.0e0_rknd
        yshift=t(16)-size/2.0e0_rknd
        zshift=t(5)
        mxhist=20
        t(1)=xshift
        t(2)=yshift
        t(3)=size
        jc(1,1)=ccolor(4_iknd,0_iknd,jp)
        jc(2,1)=ccolor(6_iknd,0_iknd,jp)
        jc(1,2)=ccolor(2_iknd,0_iknd,jp)
        jc(2,2)=ccolor(5_iknd,0_iknd,jp)
        jc(1,3)=ccolor(3_iknd,0_iknd,jp)
        jc(2,3)=ccolor(1_iknd,0_iknd,jp)
        jc(1,4)=1
        jc(2,4)=2
        sfact(1)=0.8e0_rknd/sqrt(2.0e0_rknd)
        sfact(2)=0.8e0_rknd
        sfact(3)=0.6e0_rknd
        sfact(4)=0.6e0_rknd
        do j=1,4
            num(j)=0
            num1(j)=0
        enddo
c
        do j=1,numhst
            num1(j)=int(hist(mxhist+1,j))
            num(j)=min(num1(j),mxhist)
            if(num(j)>0) then
                e1=abs(hist(mxhist+2,j))
                if(e1>0.0e0_rknd) e1=1.0e0_rknd/e1
                do i=1,num(j)
                    qq=abs(hist(i,j))*e1
                    e(i,j)=0.0e0_rknd
                    if(qq>0.0e0_rknd) e(i,j)=log10(qq)
                    ee=e(i,j)
                    if(hist(i,j)>=0.0e0_rknd) then
                        icolor(i,j)=jc(1,j)
                    else
                        icolor(i,j)=jc(2,j)
                    endif
                enddo
                ave(j)=10.0e0_rknd**(e(num(j),j)/real(num1(j),rknd))
            endif
        enddo
        n1max=num1(1)
        n1min=num1(1)
        do j=1,numhst
            if(num1(j)>0) then
                n1max=max(num1(j),n1max)
                n1min=min(num1(j),n1min)
            endif
        enddo
        if(n1max==0) return
c
        h=0.025e0_rknd
        h2=h/2.0e0_rknd
        xl=3.0e0_rknd*h
        xr=1.0e0_rknd-xl
        yl=xl
        yr=xr
        if(n1max-n1min+4<=mxhist) then
            jmin=max(n1max-mxhist,0)
c*          jmax=jmin+max(((n1max-jmin-1)/4)*4+4,8)
            jmax=jmin+mxhist
        else
            jmin=max(n1min-4,0)
            jmax=jmin+((n1max-jmin-1)/4)*4+4
        endif
        if(jmax-jmin==8) then
            numx=5
            is=2
        else if(jmax-jmin<=40) then
            numx=(jmax-jmin)/4+1
            is=4
        else
            jmax=jmin+((n1max-jmin-1)/10)*10+10
            numx=(jmax-jmin)/10+1
            is=10
        endif
        emx=ee
        emn=ee
        do j=1,numhst
            if(num(j)<=0) cycle
            do i=1,num(j)
                emx=max(e(i,j),emx)
                emn=min(e(i,j),emn)
            enddo
        enddo
        imin=int(emn)
        if(emn<real(imin,rknd)) imin=imin-1
        imax=int(emx)
        if(emx>real(imax,rknd)) imax=imax+1
        if(imax-imin<4) then
            imin=imin-(4+imin-imax)/2
            imax=imin+4
        endif
        numy=imax-imin+1
c
c       banners
c
        yyl=yr+1.8e0_rknd*h
        yyr=yyl+h
        ym=yyl+h2
        call fstr(ichr,nchr,rate(lab),0_iknd)
        xxl=h
        xxr=xxl+10.0e0_rknd*h
        call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1_iknd,q,t,2_iknd)
        do j=1,numhst
            if(num(j)<=0) cycle
            call sreal(ichr,nchr,ave(j),2_iknd,0_iknd)
            xxl=real(6+7*j,rknd)*h
            xxr=xxl+5.0e0_rknd*h
            xm=xxl-h
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1_iknd,q,t,2_iknd)
            call symbl(xm,ym,h,h,j,jc(1,j),t)
        enddo
c
c       axis
c
        call xyaxis(xl,xr,yl,yr,h,t,q,numx,jmin,
     +      is,numy,imin,1_iknd)
c
c        graph
c
        dy=(yr-yl)/real(numy-1,rknd)
        dx=(xr-xl)/real(jmax-jmin,rknd)
        do j=1,numhst
            hh=h*sfact(j)
            ishift=max(num1(j)-mxhist,0)-jmin
            i0=max(1,-ishift)
            do i=i0,num(j)
                xs=xl+dx*real(i+ishift,rknd)
                ys=yl+dy*(e(i,j)-real(imin,rknd))
                x(i)=xs*size+xshift
                y(i)=ys*size+yshift
                z(i)=zshift
                call symbl(xs,ys,hh,hh,j,icolor(i,j),t)
            enddo
            nn=num(j)-i0+1
            if(nn>1) call pline(x(i0),y(i0),z(i0),nn,2_iknd)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pthplt(jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            real(kind=rknd), dimension(5) :: x,y,z
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            character(len=80) :: ichr
            character(len=80), save :: label
            common /pltmg6/path(101,6)
cy
            data label/'continuation path'/
c
c     plot continuation path
c
        call linit(t,q)
        zshift=t(5)
        size=t(14)
        xx=t(15)-size/2.0e0_rknd
        yy=t(16)-size/2.0e0_rknd
        num=int(path(101,1))
        if(num<=0)  return
        rlmax=path(1,1)
        rlmin=rlmax
        rmax=path(1,2)
        rmin=rmax
        do i=1,num
            rlmax=max(rlmax,path(i,1))
            rlmin=min(rlmin,path(i,1))
            rmax=max(rmax,path(i,2))
            rmin=min(rmin,path(i,2))
        enddo
        dr=(rlmax-rlmin)/20.0e0_rknd
        if(dr==0.0e0_rknd) dr=abs(rlmax)/20.0e0_rknd
        if(dr==0.0e0_rknd) dr=1.0e0_rknd
        rlmax=rlmax+dr
        rlmin=rlmin-dr
        dr=(rmax-rmin)/20.0e0_rknd
        if(dr==0.0e0_rknd) dr=abs(rmax)/20.0e0_rknd
        if(dr==0.0e0_rknd) dr=1.0e0_rknd
        rmax=rmax+dr
        rmin=rmin-dr
c
        h=0.025e0_rknd*size
        xl=xx+7.0e0_rknd*h
        xr=xx+size-h
        yb=yy+2.5e0_rknd*h
        yt=yb+size-5.5e0_rknd*h
c
        srl=(xr-xl)/(rlmax-rlmin)
        sr=(yt-yb)/(rmax-rmin)
        xshift=(xr+xl)/2.0e0_rknd-srl*(rlmax+rlmin)/2.0e0_rknd
        yshift=(yb+yt)/2.0e0_rknd-sr*(rmax+rmin)/2.0e0_rknd
c
c       banners
c
        call fstr(ichr,nchr,label,0_iknd)
        xxl=xx
        xxr=xx+size
        yyl=yy+size-1.25e0_rknd*h
        yyr=yyl+h
        call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
c
c    horizontal axis
c
        do i=1,5
            z(i)=zshift
        enddo
        x(1)=xl
        x(2)=xr
        y(1)=yb
        y(2)=y(1)
        call pline(x,y,z,2_iknd,2_iknd)
        dx=(xr-xl)/10.0e0_rknd
        dr=(rlmax-rlmin)/10.0e0_rknd
        do i=1,11
            x(1)=xl+real(i-1,rknd)*dx
            x(2)=x(1)
            y(1)=yb
            y(2)=yb-0.5e0_rknd*h
            call pline(x,y,z,2_iknd,2_iknd)
            if(i-(i/2)*2==0) cycle
            xk=rlmin+real(i-1,rknd)*dr
            call sreal(ichr,nchr,xk,3_iknd,0_iknd)
            xxl=x(1)-real(nchr,rknd)*h/4.0e0_rknd
            xxr=x(1)+real(nchr,rknd)*h/4.0e0_rknd
            yyl=y(2)-1.75e0_rknd*h/2.0e0_rknd
            yyr=yyl+h/2.0e0_rknd
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
c       vertical axis
c
        x(1)=xl
        x(2)=x(1)
        y(1)=yb
        y(2)=yt
        call pline(x,y,z,2_iknd,2_iknd)
        dy=(yt-yb)/10.0e0_rknd
        dr=(rmax-rmin)/10.0e0_rknd
        do i=1,11
            xk=rmin+real(i-1,rknd)*dr
            call sreal(ichr,nchr,xk,3_iknd,0_iknd)
            x(1)=xl
            x(2)=x(1)-0.5e0_rknd*h
            y(1)=yb+real(i-1,rknd)*dy
            y(2)=y(1)
            call pline(x,y,z,2_iknd,2_iknd)
            xxl=max(x(1)-real(nchr+3,rknd)*h/2.0e0_rknd,xx)
            xxr=x(1)-h
            yyl=y(1)-h/4.0e0_rknd
            yyr=y(1)+h/4.0e0_rknd
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,1_iknd,q,t,2_iknd)
        enddo
c
c        mark points
c
        do i=1,num
            x(1)=path(i,1)*srl+xshift-h/2.0e0_rknd
            x(2)=x(1)+h
            x(3)=x(2)
            x(4)=x(1)
            x(5)=x(1)
            y(1)=path(i,2)*sr+yshift-h/2.0e0_rknd
            y(2)=y(1)
            y(3)=y(1)+h
            y(4)=y(3)
            y(5)=y(1)
            iic=int(path(i,6))
            if(iic>6) cycle
            ic=ccolor(iic,0_iknd,jp)
            call pfill(x,y,z,4_iknd,ic)
            call pline(x,y,z,5_iknd,2_iknd)
        enddo
c
c       draw interpolant
c
        if(num>1) then
            do i=1,num-1
                it1=int(path(i+1,6))
                call cpth(path(i,1),path(i+1,1),path(i,2),path(i+1,2),
     +              path(i,3),path(i+1,3),path(i,4),path(i+1,4),
     1              it1,srl,sr,xshift,yshift,zshift,xl,xr,yb,yt)
            enddo
        endif
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cpth(l0,l1,r0,r1,l0dot,l1dot,r0dot,r1dot,it1,
     +      xscale,yscale,xshift,yshift,zshift,xl,xr,yb,yt)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd) :: l0,l1,l0dot,l1dot
            real(kind=rknd), dimension(101) :: x,y,z
cy
c       compute the parabola thru two points and evaluate
c
        if(it1>=7) return
        dr=r1-r0
        dl=l1-l0
        al=sqrt(dr*dr+dl*dl)
        if(al==0.0e0_rknd) return
        c1=dr/al
        s1=dl/al
        xd1=c1*r1dot+s1*l1dot
        yd1=c1*l1dot-s1*r1dot
        xd0=c1*r0dot+s1*l0dot
        yd0=c1*l0dot-s1*r0dot
c
c
c       we are solving 4 eqns in 4 unknowns (c,q,pr,pl)
c       the eqns are (x,y) = m d (u,v) + (pr,pl)
c           m= 2x2 orthogonal
c           d = diag(1 q)
c           v= u**2
c           (solve by first eliminating pr,pl using data points
c            and the solving tangent equations for c,q)
c           it is ok to consider one point at the origin and one at (al,0)
c
        if(it1==1.or.it1==3) go to 10
        w0=2.0e0_rknd*yd0*yd1
        w1=-(xd0*yd1+xd1*yd0)
        a=sqrt(w0*w0+w1*w1)
        if(abs(a)<1.0e-2_rknd) go to 10
        c2=w0/a
        s2=w1/a
        ud0=c2*xd0+s2*yd0
        if(abs(ud0)<=1.0e-2_rknd) go to 10
        vd0=c2*yd0-s2*xd0
        c=c1*c2-s1*s2
        s=c1*s2+s1*c2
        b=((yd0*yd1)/a)*((yd1*al)/a)
        q=-1.0e0_rknd/(4.0e0_rknd*b*ud0)
        t=b*vd0/ud0
        pr=r0+(c*2.0e0_rknd*ud0-s*vd0)*t
        pl=l0+(c*vd0+s*2.0e0_rknd*ud0)*t
c
c     compute number of points
c
        num=int(abs(r0-r1)*yscale*50.0e0_rknd)
     +      +int(abs(l0-l1)*xscale*50.0e0_rknd)
        num=min(101,num)
        if(num<=2) go to 10
        u0=c*(r0-pr)+s*(l0-pl)
        u1=c*(r1-pr)+s*(l1-pl)
        h=(u1-u0)/real(num-1,rknd)
        do i=1,num
            u=u0+real(i-1,rknd)*h
            v=q*u*u
            y(i)=(pr+c*u-s*v)*yscale+yshift
            x(i)=(pl+s*u+c*v)*xscale+xshift
            z(i)=zshift
            if(x(i)<xl.or.x(i)>xr) go to 10
            if(y(i)<yb.or.y(i)>yt) go to 10
        enddo
        call pline(x,y,z,num,2_iknd)
        return
c
c    use straight line approximation
c
   10   num=2
        y(1)=r0*yscale+yshift
        y(2)=r1*yscale+yshift
        x(1)=l0*xscale+xshift
        x(2)=l1*xscale+xshift
        z(1)=zshift
        z(2)=zshift
        call pline(x,y,z,num,2_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tmhist(jp,iptr)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            real(kind=rknd), dimension(5) :: x,y,z
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(101) :: rr
            character(len=80) :: ichr
            character(len=80), save, dimension(2) :: label
            common /pltmg6/path(101,6)
cy
            data label/'time step history','utnorm history'/
c
c     plot time-step history of parabolic problem
c
        call linit(t,q)
        size=t(14)
        xx=t(15)-size/2.0e0_rknd
        yy=t(16)-size/2.0e0_rknd
        zshift=t(5)
        num=int(path(101,1))
        if(num<=1)  return
        tmin=path(1,1)
        tmax=path(num,1)
        if(tmax<=tmin) return
        rr(1)=0.0e0_rknd
        rr(2)=log10(path(2,iptr+1))
        rmax=rr(2)
        rmin=rmax
        do i=2,num
            rr(i)=log10(path(i,iptr+1))
            rmax=max(rmax,rr(i))
            rmin=min(rmin,rr(i))
        enddo
        irmax=int(rmax)+1
        irmin=int(rmin)-1
c
        h=0.025e0_rknd*size
        xl=xx+7.0e0_rknd*h
        xr=xx+size-h
        yb=yy+2.5e0_rknd*h
        yt=yb+size-5.5e0_rknd*h
c
        st=(xr-xl)/(tmax-tmin)
        sr=(yt-yb)/real(irmax-irmin,rknd)
        xshift=(xr+xl)/2.0e0_rknd-st*(tmax+tmin)/2.0e0_rknd
        yshift=(yb+yt)/2.0e0_rknd-sr*real(irmax+irmin,rknd)/2.0e0_rknd
c
c       banners
c
        call fstr(ichr,nchr,label(iptr),0_iknd)
        xxl=xx
        xxr=xx+size
        yyl=yy+size-1.25e0_rknd*h
        yyr=yyl+h
        call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
c
c    horizontal axis
c
        do i=1,5
            z(i)=zshift
        enddo
        x(1)=xl
        x(2)=xr
        y(1)=yb
        y(2)=y(1)
        call pline(x,y,z,2_iknd,2_iknd)
        dx=(xr-xl)/10.0e0_rknd
        dt=(tmax-tmin)/10.0e0_rknd
        do i=1,11
            x(1)=xl+real(i-1,rknd)*dx
            x(2)=x(1)
            y(1)=yb
            y(2)=yb-0.5e0_rknd*h
            call pline(x,y,z,2_iknd,2_iknd)
            if(i-(i/2)*2==0) cycle
            xk=tmin+real(i-1,rknd)*dt
            call sreal(ichr,nchr,xk,3_iknd,0_iknd)
            xxl=x(1)-real(nchr,rknd)*h/4.0e0_rknd
            xxr=x(1)+real(nchr,rknd)*h/4.0e0_rknd
            yyl=y(2)-1.75e0_rknd*h/2.0e0_rknd
            yyr=yyl+h/2.0e0_rknd
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
c       vertical axis
c
        x(1)=xl
        x(2)=x(1)
        y(1)=yb
        y(2)=yt
        call pline(x,y,z,2_iknd,2_iknd)
        dy=(yt-yb)/10.0e0_rknd
        if(irmax-irmin<10) then
            nn=irmax-irmin+1
            inc=1
        else
            nn=(irmax-irmin)/2+1
            inc=2
        endif
        dy=(yt-yb)/real(nn-1,rknd)
        do i=1,nn
            k=irmin+(i-1)*inc
            call sint(ichr,nchr,k)
            x(1)=xl
            x(2)=x(1)-0.5e0_rknd*h
            y(1)=yb+real(i-1,rknd)*dy
            y(2)=y(1)
            call pline(x,y,z,2_iknd,2_iknd)
            xxl=max(x(1)-real(nchr+3,rknd)*h/2.0e0_rknd,xx)
            xxr=x(1)-h
            yyl=y(1)-h/4.0e0_rknd
            yyr=y(1)+h/4.0e0_rknd
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,-1_iknd,q,t,2_iknd)
        enddo
c
c        mark points
c
        do i=2,num
            x(1)=path(i,1)*st+xshift-h/2.0e0_rknd
            x(2)=x(1)+h
            x(3)=x(2)
            x(4)=x(1)
            x(5)=x(1)
            y(1)=rr(i)*sr+yshift-h/2.0e0_rknd
            y(2)=y(1)
            y(3)=y(1)+h
            y(4)=y(3)
            y(5)=y(1)
            ic=ccolor(4_iknd,0_iknd,jp)
            if(int(path(i,6))<0) ic=ccolor(6_iknd,0_iknd,jp)
            call pfill(x,y,z,4_iknd,ic)
            call pline(x,y,z,5_iknd,2_iknd)
            if(i>2) then
                x(1)=path(i-1,1)*st+xshift
                x(2)=path(i,1)*st+xshift
                y(1)=rr(i-1)*sr+yshift
                y(2)=rr(i)*sr+yshift
                call pline(x,y,z,2_iknd,2_iknd)
            endif
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ipmplt(jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(100) :: ic
            integer(kind=iknd), save, dimension(6) :: icc
            integer(kind=iknd) :: ccolor
            real(kind=rknd), dimension(100) :: rn,rho,rmu,x,y,z,xn,yn,zn
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            character(len=80) :: ichr
            character(len=80), save :: label
            common /pltmg6/path(101,6)
cy
            data label/'interior point history'/
            data icc/6,2,5,3,1,4/
c
c       initialize
c
        call linit(t,q)
        size=t(14)
        xx=t(15)-size/2.0e0_rknd
        yy=t(16)-size/2.0e0_rknd
        t(1)=xx
        t(2)=yy
        t(3)=size
c
        num=int(path(101,1))
        if(num<=0) return
c
c       set up input arrays
c
        do i=1,num
            rmu(i)=log10(path(i,1))
            rho(i)=log10(abs(path(i,2)))
            rn(i)=log10(path(i,3))
            ii=int(path(i,6))
            if(ii<1) ii=1
            if(ii>6) ii=6
            ic(i)=ccolor(icc(ii),0_iknd,jp)
        enddo
c
        rnmax=rn(1)
        rmumax=rmu(1)
        rmumin=rmumax
        rhomax=rho(1)
        rhomin=rhomax
        do i=1,num
            rnmax=max(rn(i),rnmax)
            rmumax=max(rmu(i),rmumax)
            rmumin=min(rmu(i),rmumin)
            rhomax=max(rho(i),rhomax)
            rhomin=min(rho(i),rhomin)
        enddo
c
        numx=max(5,int(rnmax)+2)
        iminy=int(rmumin)
        if(rmumin<real(iminy,rknd)) iminy=iminy-1
        imaxy=int(rmumax)
        if(rmumax>real(imaxy,rknd)) imaxy=imaxy+1
        if(imaxy-iminy<4) then
            iminy=iminy-(4+iminy-imaxy)/2
            imaxy=iminy+4
        endif
        numy=imaxy-iminy+1
        iminz=int(rhomin)
        if(rhomin<real(iminz,rknd)) iminz=iminz-1
        imaxz=int(rhomax)
        if(rhomax>real(imaxz,rknd)) imaxz=imaxz+1
        if(imaxz-iminz<4) then
            iminz=iminz-(4+iminz-imaxz)/2
            imaxz=iminz+4
        endif
        numz=imaxz-iminz+1
c
        h=0.025e0_rknd
        xl=3.0e0_rknd*h
        xr=1.0e0_rknd-xl
        yl=xl
        yr=xr
        zl=xl
        zr=xr
c
c       banners
c
        call fstr(ichr,nchr,label,0_iknd)
        xxl=0.0e0_rknd
        xxr=1.0e0_rknd
        yyl=1.0e0_rknd-h
        yyr=1.0e0_rknd
        call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
c
c       set up rotated coordinate system
c
        call mkrot(jp(13),jp(14),jp(15),q)
c
        xmin=min(0.0e0_rknd,q(1,1))+min(0.0e0_rknd,q(2,1))
        xmax=max(0.0e0_rknd,q(1,1))+max(0.0e0_rknd,q(2,1))
        ymin=min(0.0e0_rknd,q(1,2))+min(0.0e0_rknd,q(2,2))
        ymax=max(0.0e0_rknd,q(1,2))+max(0.0e0_rknd,q(2,2))+q(3,2)
        zmin=min(0.0e0_rknd,q(1,3))
     +      +min(0.0e0_rknd,q(2,3))+min(0.0e0_rknd,q(3,3))
        zmax=max(0.0e0_rknd,q(1,3))
     +      +max(0.0e0_rknd,q(2,3))+max(0.0e0_rknd,q(3,3))
c
        scale=size/max(xmax-xmin,ymax-ymin)
        xshift=xx+(size-scale*(xmax+xmin))/2.0e0_rknd
        yshift=yy+(size-scale*(ymax+ymin))/2.0e0_rknd
        zshift=   (size-scale*(zmax+zmin))/2.0e0_rknd
        t(1)=xshift
        t(2)=yshift
        t(5)=zshift
        t(3)=scale
c
        dx=(xr-xl)/real(numx-1,rknd)
        dz=(zr-zl)/real(numz-1,rknd)
        dy=(yr-yl)/real(numy-1,rknd)
        do i=1,num
            x(i)=xl+dx*rn(i)
            y(i)=yl+dy*(rmu(i)-real(iminy,rknd))
            z(i)=zl+dz*(rho(i)-real(iminz,rknd))
            xn(i)=(x(i)*q(1,1)+y(i)*q(2,1))*scale+xshift
            yn(i)=(x(i)*q(1,2)+y(i)*q(2,2)+z(i)*q(3,2))*scale+yshift
            zn(i)=(x(i)*q(1,3)+y(i)*q(2,3)+z(i)*q(3,3))*scale+zshift
        enddo
c
c       we must call routines in right order to get the
c       hidden lines right
c
        if(q(3,3)>0.0e0_rknd) then
            call xygrid(xl,xr,yl,yr,zl,h,t,q,
     +          numx,0_iknd,1_iknd,numy,iminy,1_iknd)
        else
            call pline(xn,yn,zn,num,2_iknd)
        endif
        isw=1
        if(q(2,3)<0.0e0_rknd) then
            do i=num,1,-1
                call cbox(x(i),y(i),z(i),zl,h,t,q,ic(i),isw)
            enddo
            call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1_iknd)
         else
            call zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,1_iknd)
            do i=1,num
                call cbox(x(i),y(i),z(i),zl,h,t,q,ic(i),isw)
            enddo
        endif
        if(q(3,3)<=0.0e0_rknd) then
            call xygrid(xl,xr,yl,yr,zl,h,t,q,
     +          numx,0_iknd,1_iknd,numy,iminy,1_iknd)
        else
            call pline(xn,yn,zn,num,2_iknd)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dbugi(sub,name,nrow,ncol,ia)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ia
            character(len=6) :: sub,name
            character(len=80) :: list,blank
cy
        blank=' '
        call filutl(blank,0_iknd)
        if(nrow==1.and.ncol==1) then
            write(unit=list,fmt='(a11,a6,3x,a9,a6,3x,a6,i6)')
     +          'subroutine:',sub,'variable:',name,'value:',ia(1)
            call filutl(list,0_iknd)
            call filutl(blank,0_iknd)
            return
        else
            write(unit=list,fmt='(a11,a6,3x,a9,a6)')
     +          'subroutine:',sub,'variable:',name
            call filutl(list,0_iknd)
            call filutl(blank,0_iknd)
        endif
        if(ncol==1) then
            do irow=1,nrow,6
                i5=min(irow+5,nrow)
                write(unit=list,fmt='(a4,i6,3x,6i8)')
     +              'row:',irow,(ia(i),i=irow,i5)
                call filutl(list,0_iknd)
            enddo
        else
            do icol=1,ncol
                ii=(icol-1)*nrow
                write(unit=list,fmt='(a4,i6,3x,6i8)')
     +              'col:',icol,(ia(i),i=ii+1,ii+nrow)
                call filutl(list,0_iknd)
            enddo
        endif
        call filutl(blank,0_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dbugr(sub,name,nrow,ncol,a)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: a
            character(len=6) :: sub,name
            character(len=80) :: list,blank
cy
        blank=' '
        call filutl(blank,0_iknd)
        if(nrow==1.and.ncol==1) then
            write(unit=list,fmt='(a11,a6,3x,a9,a6,3x,a6,e12.4)')
     +          'subroutine:',sub,'variable:',name,'value:',a(1)
            call filutl(list,0_iknd)
            call filutl(blank,0_iknd)
            return
        else
            write(unit=list,fmt='(a11,a6,3x,a9,a6)')
     +          'subroutine:',sub,'variable:',name
            call filutl(list,0_iknd)
            call filutl(blank,0_iknd)
        endif
        if(ncol==1) then
            do irow=1,nrow,4
                i3=min(irow+3_iknd,nrow)
                write(unit=list,fmt='(a4,i6,3x,4e12.4)')
     +              'row:',irow,(a(i),i=irow,i3)
                call filutl(list,0_iknd)
            enddo
        else
            do icol=1,ncol
                ii=(icol-1)*nrow
                write(unit=list,fmt='(a4,i6,3x,4e12.4)')
     +              'col:',icol,(a(i),i=ii+1,ii+nrow)
                call filutl(list,0_iknd)
            enddo
        endif
        call filutl(blank,0_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine prtpth(irgn,nproc,ipath)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(6,*) :: ipath
            character(len=80) :: list,blank
cy
        blank=' '
        call filutl(blank,0_iknd)
        write(unit=list,fmt='(a6,i3,3x,a5,i3)')
     +          'nproc:',nproc,'irgn:',irgn
        call filutl(list,0_iknd)
        do i=1,nproc+1
           iv1=ipath(3,i)
           iv2=ipath(4,i)
           ie1=ipath(1,i)
           ie2=ipath(2,i)
           call filutl(blank,0_iknd)
           write(unit=list,fmt='(a7,i3,2(3x,a6,2i6))')
     +          'region:',i,'verts:',iv1,iv2,'edges:',ie1,ie2
           call filutl(list,0_iknd)
           call filutl(blank,0_iknd)
           do k=ie1,ie2
           write(unit=list,fmt='(a7,i6,2x,6i6)')
     +          'column:',k,(ipath(j,k),j=1,6)
           call filutl(list,0_iknd)
           enddo
        enddo
        i=nproc+2
        iv1=ipath(3,i)
        iv2=ipath(4,i)
        ie1=ipath(1,i)
        ie2=ipath(2,i)
        call filutl(blank,0_iknd)
        write(unit=list,fmt='(a8,i3,2(3x,a6,2i6))')
     +       'nproc+2:',i,'verts:',iv1,iv2,'edges:',ie1,ie2
        call filutl(list,0_iknd)
        call filutl(blank,0_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine aveprt(ptime,jp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            real(kind=rknd), dimension(*) :: ptime
            character(len=80) :: list
cy
        ntf=jp(1)
        if(ntf<=0) return
        nproc=jp(2)
        tmx=ptime(1)
        tmn=ptime(1)
        ave=0.0e0_rknd
        do i=1,nproc
            tmx=max(tmx,ptime(i))
            tmn=min(tmn,ptime(i))
            ave=ave+ptime(i)
        enddo
        ave=ave/real(nproc,rknd)
c
        write(unit=list,fmt='(a19,f7.2,a9,f7.2,a4,f7.2)')
     +          'mpi: average time =',ave,'  range =',tmn,
     1          ' -- ',tmx
        call filutl(list,0_iknd)
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine nwtprt(hist)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(22,2) :: e
            real(kind=rknd), dimension(22,*) :: hist
            character(len=80) :: list
            character(len=80), save, dimension(3) :: label
cy
            data label/'newton residual -- newton increment',
     +                 'upper bound --lower bound',
     1                 'dd residual -- dd increment'/
c
c     graph error
c
        mxhist=20
c
        lab1=int(hist(mxhist+1,2))
        if(lab1==-1) then
            lab=3
        else if(lab1==-2) then
            lab=2
        else
            lab=1
        endif
        num1=int(hist(mxhist+1,1))
        num=min(num1,mxhist)
        if(num<=0) return
        do j=1,2
            e1=abs(hist(mxhist+2,j))
            if(e1>0.0e0_rknd) e1=1.0e0_rknd/e1
            do i=1,num
                qq=abs(hist(i,j))*e1
                e(i,j)=0.0e0_rknd
                if(qq>0.0e0_rknd) e(i,j)=log10(qq)
            enddo
        enddo
c
        list=label(lab)
        call filutl(list,0_iknd)
        do i=1,num
            write(unit=list,fmt='(a10,i4,2f9.2)')
     +          'iteration:',i,e(i,1),e(i,2)
            call filutl(list,0_iknd)
        enddo
        if(num<=1) return
        r1=10.0e0_rknd**((e(num,1)-e(1,1))/real(num-1,rknd))
        r2=10.0e0_rknd**((e(num,2)-e(1,2))/real(num-1,rknd))
        write(unit=list,fmt='(a20,2f9.2)')
     +      'convergence factors:',r1,r2
        call filutl(list,0_iknd)
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine xyaxis(xl,xr,yl,yr,h,t,q,numx,iminx,
     +      incx,numy,iminy,incy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(2) :: x,y,z
            character(len=80) :: ichr
cy
        dx=(xr-xl)/(numx-1)
        dy=(yr-yl)/(numy-1)
        xshift=t(1)
        yshift=t(2)
        zshift=t(5)
        scale=t(3)
        h2=h/2.0e0_rknd
c
c    x - axis
c
        z(1)=zshift
        z(2)=zshift
        x(1)=xl*scale+xshift
        y(1)=yl*scale+yshift
        x(2)=xr*scale+xshift
        y(2)=y(1)
        call pline(x,y,z,2_iknd,2_iknd)
        do i=1,numx
            k=iminx+(i-1)*incx
            call sint(ichr,nchr,k)
            xx=xl+real(i-1,rknd)*dx
            x(1)=xx*scale+xshift
            y(1)=(yl+h2)*scale+yshift
            x(2)=x(1)
            y(2)=yl*scale+yshift
            call pline(x,y,z,2_iknd,2_iknd)
            xxl=xx-real(nchr,rknd)*h2
            xxr=xx+real(nchr,rknd)*h2
            yyl=yl-2.25e0_rknd*h
            yyr=yyl+h
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
c
c    y-axis
c
        x(1)=xl*scale+xshift
        y(1)=yl*scale+yshift
        x(2)=x(1)
        y(2)=yr*scale+yshift
        call pline(x,y,z,2_iknd,2_iknd)
        do i=1,numy
            k=iminy+(i-1)*incy
            call sint(ichr,nchr,k)
            yy=yl+real(i-1,rknd)*dy
            x(1)=(xl+h2)*scale+xshift
            y(1)=yy*scale+yshift
            x(2)=xl*scale+xshift
            y(2)=y(1)
            call pline(x,y,z,2_iknd,2_iknd)
            xxl=xl-real(2*nchr+1,rknd)*h2
            xxr=xl-h2
            yyl=yy-h2
            yyr=yy+h2
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q,t,2_iknd)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine symbl(xm,ym,hx,hy,itype,icolor,t)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save, dimension(5) :: iptr
            integer(kind=iknd), save, dimension(14) :: px,py
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(5) :: x,y,z
cy
            data iptr/1,5,9,12,15/
            data px/-1,1,1,-1,1,0,-1,0,-1,1,0,0,1,-1/
            data py/-1,-1,1,1,0,1,0,-1,-1,-1,1,-1,1,1/
c
c       itype = 1 box   itype = 2 diamond  itype = 3,4 triangle
c
        xshift=t(1)
        yshift=t(2)
        scale=t(3)
        zshift=t(5)
        istart=iptr(itype)
        num=iptr(itype+1)-istart
        do i=1,num
            px0=real(px(i+istart-1),rknd)/2.0e0_rknd
            py0=real(py(i+istart-1),rknd)/2.0e0_rknd
            x(i)=(xm+hx*px0)*scale+xshift
            y(i)=(ym+hy*py0)*scale+yshift
            z(i)=zshift
        enddo
        x(num+1)=x(1)
        y(num+1)=y(1)
        z(num+1)=z(1)
        call pfill(x,y,z,num,icolor)
        call pline(x,y,z,num+1_iknd,2_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine xygrid(xl,xr,yl,yr,zl,h,t,q,numx,iminx,
     +      incx,numy,iminy,incy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(25) :: t,t0
            real(kind=rknd), dimension(3,3) :: q,q0
            real(kind=rknd), dimension(2) :: x,y,z
            character(len=80) :: ichr
cy
        dx=(xr-xl)/(numx-1)
        dy=(yr-yl)/(numy-1)
        xshift=t(1)
        yshift=t(2)
        zshift=t(5)
        scale=t(3)
        h2=h/2.0e0_rknd
        zm=zl-h2
        zp=zl+h2
        do i=1,25
            t0(i)=t(i)
        enddo
c
c    x - axis
c
        if(q(2,3)==0.0e0_rknd.and.q(3,3)==0.0e0_rknd) go to 10
        nn=numy
        if(q(3,3)==0.0e0_rknd) nn=1
        do i=1,nn
            yy=yl+real(i-1,rknd)*dy
            x(1)=(xl*q(1,1)+yy*q(2,1))*scale+xshift
            y(1)=(xl*q(1,2)+yy*q(2,2)+zl*q(3,2))*scale+yshift
            z(1)=(xl*q(1,3)+yy*q(2,3)+zl*q(3,3))*scale+zshift
            x(2)=(xr*q(1,1)+yy*q(2,1))*scale+xshift
            y(2)=(xr*q(1,2)+yy*q(2,2)+zl*q(3,2))*scale+yshift
            z(2)=(xr*q(1,3)+yy*q(2,3)+zl*q(3,3))*scale+zshift
            call pline(x,y,z,2_iknd,2_iknd)
        enddo
        do i=1,3
            q0(1,i)=q(1,i)
            q0(2,i)=q(3,i)
            q0(3,i)=-q(2,i)
        enddo
        t0(1)=xshift+q(2,1)*scale*(yl-h)
        t0(2)=yshift+q(2,2)*scale*(yl-h)
        t0(5)=zshift+q(2,3)*scale*(yl-h)
        do i=1,numx
            k=iminx+(i-1)*incx
            call sint(ichr,nchr,k)
            xx=xl+real(i-1,rknd)*dx
            x(1)=(xx*q(1,1)+yl*q(2,1))*scale+xshift
            y(1)=(xx*q(1,2)+yl*q(2,2)+zm*q(3,2))*scale+yshift
            z(1)=(xx*q(1,3)+yl*q(2,3)+zm*q(3,3))*scale+zshift
            x(2)=(xx*q(1,1)+yl*q(2,1))*scale+xshift
            y(2)=(xx*q(1,2)+yl*q(2,2)+zp*q(3,2))*scale+yshift
            z(2)=(xx*q(1,3)+yl*q(2,3)+zp*q(3,3))*scale+zshift
            call pline(x,y,z,2_iknd,2_iknd)
            xxl=xx-real(nchr,rknd)*h2
            xxr=xx+real(nchr,rknd)*h2
            yyl=zl-2.25e0_rknd*h
            yyr=yyl+h
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q0,t0,2_iknd)
        enddo
c
c    y-axis
c
   10   if(q(1,3)==0.0e0_rknd.and.q(3,3)==0.0e0_rknd) return
        nn=numx
        if(q(3,3)==0.0e0_rknd) nn=1
        do i=1,nn
            xx=xl+real(i-1,rknd)*dx
            x(1)=(xx*q(1,1)+yl*q(2,1))*scale+xshift
            y(1)=(xx*q(1,2)+yl*q(2,2)+zl*q(3,2))*scale+yshift
            z(1)=(xx*q(1,3)+yl*q(2,3)+zl*q(3,3))*scale+zshift
            x(2)=(xx*q(1,1)+yr*q(2,1))*scale+xshift
            y(2)=(xx*q(1,2)+yr*q(2,2)+zl*q(3,2))*scale+yshift
            z(2)=(xx*q(1,3)+yr*q(2,3)+zl*q(3,3))*scale+zshift
            call pline(x,y,z,2_iknd,2_iknd)
        enddo
        do i=1,3
            q0(1,i)=q(2,i)
            q0(2,i)=q(3,i)
            q0(3,i)=q(1,i)
        enddo
        t0(1)=xshift+q(1,1)*scale*(xl-h)
        t0(2)=yshift+q(1,2)*scale*(xl-h)
        t0(5)=zshift+q(1,3)*scale*(xl-h)
        do i=1,numy
            k=iminy+(i-1)*incy
            call sint(ichr,nchr,k)
            yy=yl+real(i-1,rknd)*dy
            x(1)=(xl*q(1,1)+yy*q(2,1))*scale+xshift
            y(1)=(xl*q(1,2)+yy*q(2,2)+zm*q(3,2))*scale+yshift
            z(1)=(xl*q(1,3)+yy*q(2,3)+zm*q(3,3))*scale+zshift
            x(2)=(xl*q(1,1)+yy*q(2,1))*scale+xshift
            y(2)=(xl*q(1,2)+yy*q(2,2)+zp*q(3,2))*scale+yshift
            z(2)=(xl*q(1,3)+yy*q(2,3)+zp*q(3,3))*scale+zshift
            call pline(x,y,z,2_iknd,2_iknd)
            xxl=yy-real(nchr,rknd)*h2
            xxr=yy+real(nchr,rknd)*h2
            yyl=zl-2.25e0_rknd*h
            yyr=yyl+h
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q0,t0,2_iknd)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine zaxis(xl,yl,zl,zr,h,t,q,numz,iminz,incz)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(25) :: t,t0
            real(kind=rknd), dimension(3,3) :: q,q0
            real(kind=rknd), dimension(3) :: x,y,z
            character(len=80) :: ichr
cy
        dz=(zr-zl)/(numz-1)
        xshift=t(1)
        yshift=t(2)
        zshift=t(5)
        scale=t(3)
        h2=h/2.0e0_rknd
        xp=xl+h2
        yp=yl+h2
        do i=1,25
            t0(i)=t(i)
        enddo
        if(abs(q(1,3))<abs(q(2,3))) then
            do i=1,3
                q0(1,i)=q(1,i)
                q0(2,i)=q(3,i)
                q0(3,i)=-q(2,i)
            enddo
            t0(1)=xshift+q(2,1)*scale*(yl-h)
            t0(2)=yshift+q(2,2)*scale*(yl-h)
            t0(5)=zshift+q(2,3)*scale*(yl-h)
        else
            do i=1,3
                q0(1,i)=q(2,i)
                q0(2,i)=q(3,i)
                q0(3,i)=q(1,i)
            enddo
            t0(1)=xshift+q(1,1)*scale*(xl-h)
            t0(2)=yshift+q(1,2)*scale*(xl-h)
            t0(5)=zshift+q(1,3)*scale*(xl-h)
        endif
c
c    z - axis
c
        x(1)=(xl*q(1,1)+yl*q(2,1))*scale+xshift
        y(1)=(xl*q(1,2)+yl*q(2,2)+zl*q(3,2))*scale+yshift
        z(1)=(xl*q(1,3)+yl*q(2,3)+zl*q(3,3))*scale+zshift
        x(2)=(xl*q(1,1)+yl*q(2,1))*scale+xshift
        y(2)=(xl*q(1,2)+yl*q(2,2)+zr*q(3,2))*scale+yshift
        z(2)=(xl*q(1,3)+yl*q(2,3)+zr*q(3,3))*scale+zshift
        call pline(x,y,z,2_iknd,2_iknd)
        do i=1,numz
            k=iminz+(i-1)*incz
            call sint(ichr,nchr,k)
            zz=zl+real(i-1,rknd)*dz
            x(1)=(xp*q(1,1)+yl*q(2,1))*scale+xshift
            y(1)=(xp*q(1,2)+yl*q(2,2)+zz*q(3,2))*scale+yshift
            z(1)=(xp*q(1,3)+yl*q(2,3)+zz*q(3,3))*scale+zshift
            x(2)=(xl*q(1,1)+yl*q(2,1))*scale+xshift
            y(2)=(xl*q(1,2)+yl*q(2,2)+zz*q(3,2))*scale+yshift
            z(2)=(xl*q(1,3)+yl*q(2,3)+zz*q(3,3))*scale+zshift
            x(3)=(xl*q(1,1)+yp*q(2,1))*scale+xshift
            y(3)=(xl*q(1,2)+yp*q(2,2)+zz*q(3,2))*scale+yshift
            z(3)=(xl*q(1,3)+yp*q(2,3)+zz*q(3,3))*scale+zshift
            call pline(x,y,z,3_iknd,2_iknd)
c
            xxl=xl-real(nchr+1,rknd)*h
            xxr=xl-h
            yyl=zz-h2
            yyr=zz+h2
            call htext(xxl,yyl,xxr,yyr,nchr,ichr,0_iknd,q0,t0,2_iknd)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cbox(x,y,z,zl,h,t,q,icolor,isw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save, dimension(4,6) :: face
            integer(kind=iknd), save, dimension(6) :: order
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), save, dimension(8) :: px,py,pz
            integer(kind=iknd), save :: istrt
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(5) :: xn,yn,zn
cy
        data px/0,1,1,0,0,1,1,0/
        data py/0,0,1,1,0,0,1,1/
        data pz/0,0,0,0,1,1,1,1/
        data face/4,1,5,8,2,3,7,6,1,2,6,5,3,4,8,7,4,3,2,1,5,6,7,8/
        data index/1,2,3,2,3,1,3,1,2/
c
        if(isw==1) then
c
c       compute order
c
            kmin=1
            if(abs(q(kmin,3))>abs(q(2,3))) kmin=2
            if(abs(q(kmin,3))>abs(q(3,3))) kmin=3
            kmid=index(2,kmin)
            kmax=index(3,kmin)
            if(abs(q(kmid,3))>abs(q(kmax,3))) kmid=kmax
            kmax=6-kmin-kmid
c
            if(q(kmax,3)>0.0e0_rknd) then
                order(1)=2*kmax-1
                order(6)=2*kmax
            else
                order(6)=2*kmax-1
                order(1)=2*kmax
            endif
            if(q(kmid,3)>0.0e0_rknd) then
                order(2)=2*kmid-1
                order(5)=2*kmid
            else
                order(5)=2*kmid-1
                order(2)=2*kmid
            endif
            if(q(kmin,3)>0.0e0_rknd) then
                order(3)=2*kmin-1
                order(4)=2*kmin
            else
                order(4)=2*kmin-1
                order(3)=2*kmin
            endif
c
            tol=1.0e-3_rknd
            istrt=6
            if(abs(q(kmin,3))>tol) then
                istrt=4
            else if(abs(q(kmid,3))>tol) then
                istrt=5
            endif
        endif
        xshift=t(1)
        yshift=t(2)
        zshift=t(5)
        scale=t(3)
        h2=h/2.0e0_rknd
        do i=istrt,6
           ii=order(i)
           do j=1,4
                xx=x-h2+h*real(px(face(j,ii)),rknd)
                yy=y-h2+h*real(py(face(j,ii)),rknd)
                zz=zl+(z-zl)*real(pz(face(j,ii)),rknd)
                xn(j)=(xx*q(1,1)+yy*q(2,1))*scale+xshift
                yn(j)=(xx*q(1,2)+yy*q(2,2)+zz*q(3,2))*scale+yshift
                zn(j)=(xx*q(1,3)+yy*q(2,3)+zz*q(3,3))*scale+zshift
           enddo
           xn(5)=xn(1)
           yn(5)=yn(1)
           zn(5)=zn(1)
           call pfill(xn,yn,zn,4_iknd,icolor)
           call pline(xn,yn,zn,5_iknd,2_iknd)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mktris(nbf,nvv,ip,vx,vy,ibndry,itnode,sf,jt,
     +      jtnode,jtedge,ntf,iclrsw,nrl,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,jtnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3*nbf) :: jb
            integer(kind=iknd), dimension(*) :: jt
            integer(kind=iknd), dimension(3,*) :: jtedge
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), dimension(nvv) :: index
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
c
c       make a crude triangulation of the skeleton
c
        ntr=ip(1)
        nvr=ip(2)
        nbr=ip(3)
c
c       make jb
c
        call makjb(nvr,nbr,ntr,vx,vy,sf,ibndry,itnode,1_iknd,jb,
     +      iflag,nrl,rl,sxy)
        if(iflag/=0) then
            ip(25)=iflag
            return
        endif
c
        ntf=0
        do itag=1,ntr
            nb1=jb(itag)
            nb2=jb(itag+1)-1
            ivc=itnode(1,itag)
            nn=0
            do jj=nb1,nb2
                it=jb(jj)
                ivn=ibndry(1,it)+ibndry(2,it)-ivc
                nn=nn+1
                index(nn)=ivc
                ivc=ivn
            enddo
            nt1=ntf+1
            jt(itag)=nt1
            j4tag=0
            if(iclrsw==1) then
                j5tag=itnode(4,itag)
            else if(iclrsw==2) then
                j5tag=itag
            else
                j5tag=itnode(5,itag)
            endif
            call trisk(nn,vx,vy,index,ntf,jtnode,j4tag,j5tag)
c***        write(6,*) itag,nb1,nb2,nt1,ntf,nn,ntf-nt1+1-nn+2
            call cedgek(nvr,nt1,ntf,nb1,nb2,jtnode,ibndry,jtedge,jb)
            call eswapk(nt1,ntf,jtnode,jtedge,vx,vy)
        enddo
        jt(ntr+1)=ntf+1
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine trisk(nvf,vx,vy,index,ntf,itnode,i4tag,i5tag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(2*nvf) :: istart,istop
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(nvf) :: list
            integer(kind=iknd), dimension(*) :: index
            real(kind=rknd), dimension(*) :: vx,vy
cy
c
c       triangulate the region give in vx,vy
c
c***    ntf0=ntf
        nrgn=1
        istart(1)=1
        istop(1)=nvf
c**     eps=0.0e0_rknd
        eps=1.0e1_rknd*epsilon(1.0e0_rknd)
c
c
   10   ibegin=istart(nrgn)
        iend=istop(nrgn)
        nrgn=nrgn-1
c
c       compute vertices visible from ibegin  (not counting
c       the immediate neighbors of ibegin)
c
        llist=1
        kk=ibegin+1
        list(1)=kk
        do l=ibegin+2,iend
            if(kk==iend) exit
            kk=kk+1
            llist=llist+1
            list(llist)=kk
            ka=list(llist)
            kb=list(llist-1)
            aa=geom(index(ibegin),index(kb),index(ka),vx,vy)
c
c       the standard case
c
            if(aa>eps) cycle
            ac=geom(index(kb-1),index(kb),index(ka),vx,vy)
c
c       boundary bends away from ibegin
c
            if(ac<=eps.or.llist<=2) then
                iwind=0
                sn=1.0e0_rknd
   20           if(kk==iend) exit
                kk=kk+1
                list(llist)=kk
                ak=sn*geom(index(ibegin),index(kb),index(kk),vx,vy)
                if(ak>eps) then
                    qq=geom(index(ibegin),index(kk-1),index(kk),vx,vy)
                    if(qq>eps) then
                        iwind=iwind-1
                        if(iwind<0) cycle
                    else
                        iwind=iwind+1
                    endif
                    sn=-sn
                endif
                go to 20
            endif
c
c       the  boundary bends towards ibegin
c
            llist=llist-1
            list(llist)=ka
c
c       delete a back points
c
   30       kb=list(llist-1)
            aa=geom(index(ibegin),index(kb),index(ka),vx,vy)
            if(aa<=eps) then
                ac=geom(index(ka-1),index(kb),index(ka),vx,vy)
c
c       if we skip outside view
c
                if(ac>=eps.or.llist<=2) then
                     sn=1.0e0_rknd
   50                if(kk==iend) exit
                     kk=kk+1
                     list(llist)=kk
                     ak=sn*geom(index(ibegin),index(kb),index(kk),
     +                  vx,vy)
                     if(ak>eps) then
                         if(sn==1.0e0_rknd) then
                             qq=geom(index(ka-1),index(ka),index(kk),
     +                          vx,vy)
                             if(qq<eps) cycle
                         endif
                         sn=-sn
                     endif
                     go to 50
                endif
                llist=llist-1
                list(llist)=ka
                go to 30
            endif
c
c       look for turning point
c
            if(kk==iend) exit
            kk=kk+1
            llist=llist+1
            list(llist)=kk
            ka=list(llist)
            kasave=ka
            kb=list(llist-1)
            aa=geom(index(ibegin),index(kb),index(ka),vx,vy)
            if(aa>eps) then
                ac=geom(index(ka),index(kb),index(kb-1),vx,vy)
                if(ac>-eps) cycle
c
c       now we have to work through the backward bending branch
c
                llist=llist-1
   60           if(kk==iend) exit
                kk=kk+1
                list(llist)=kk
                ak=geom(index(ibegin),index(kb),index(kk),vx,vy)
                if(ak>=eps) go to 60
                ka=list(llist)
                kb=kasave
            else
                llist=llist-1
                list(llist)=ka
            endif
            go to 30
c
        enddo
c
c       make new triangles
c
   80   if(list(llist)/=iend) then
            if(llist<2) stop 8094
            list(llist)=iend
            kb=list(llist-1)
            aa=geom(index(ibegin),index(kb),index(iend),vx,vy)
            if(aa<=0.0e0_rknd) then
                llist=llist-1
                go to 80
            endif
        endif
        nrsv=nrgn
        ntsv=ntf
        do i=1,llist-1
            ntf=ntf+1
            itnode(1,ntf)=index(ibegin)
            itnode(2,ntf)=index(list(i))
            itnode(3,ntf)=index(list(i+1))
            itnode(4,ntf)=i4tag
            itnode(5,ntf)=i5tag
            if(list(i+1)/=list(i)+1) then
                nrgn=nrgn+1
                istart(nrgn)=list(i)
                istop(nrgn)=list(i+1)
            endif
        enddo
c
c       this is just a consistency check
c
        mxtri=iend-ibegin-1
        nwtri=ntf-ntsv
        if(nrsv<nrgn) then
            do m=nrsv+1,nrgn
                nwtri=nwtri+istop(m)-istart(m)-1
            enddo
        endif
c       if(mxtri/=nwtri) then
c           call drgrdz(ibegin,iend,index,vx,vy,ntsv,ntf,itnode)
c       endif
        if(mxtri/=nwtri) stop 6781
        if(nrgn>0) go to 10
c***    call drgrdx(vx,vy,nvf,ntf0,ntf,itnode)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine eswapk(nt1,nt2,itnode,itedge,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       this routine swaps interior triangle edges in an attempt
c       to improve the overall quality of the triangulation
c
        itmax=10
        tol=0.0e0_rknd
c
c       the main loop
c
        do itnum=1,itmax
            ichng=0
            do i=nt1,nt2
                do j=1,3
                    k=itedge(j,i)/4
                    if(k<=i) cycle
                    kj=itedge(j,i)-4*k
                    ii=itnode(j,i)
                    j1=index(2,j)
                    j2=index(3,j)
                    n1=itnode(j1,i)
                    n2=itnode(j2,i)
                    kk=itnode(kj,k)
                    q1=geom(n1,kk,ii,vx,vy)
                    q2=geom(n2,ii,kk,vx,vy)
                    r1=geom(n1,n2,ii,vx,vy)
                    r2=geom(n2,n1,kk,vx,vy)
                    if(min(q1,q2)<min(r1,r2)+tol) cycle
c
c       swap edges
c
                    ichng=ichng+1
                    k1=index(3,kj)
                    k2=index(2,kj)
                    itnode(j1,i)=kk
                    itnode(k2,k)=ii
                    itedge(j,i)=itedge(k1,k)
                    itedge(kj,k)=itedge(j2,i)
                    itedge(j2,i)=k*4+k1
                    itedge(k1,k)=i*4+j2
c
c       fixup neighboring elements
c
                    li=itedge(j,i)/4
                    if(li>0) then
                        ll=itedge(j,i)-4*li
                        itedge(ll,li)=4*i+j
                    endif
                    lk=itedge(kj,k)/4
                    if(lk>0) then
                        ll=itedge(kj,k)-4*lk
                        itedge(ll,lk)=4*k+kj
                    endif
                enddo
            enddo
            if(ichng<=0) return
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cedgek(nvf,nt1,nt2,nb1,nb2,itnode,ibndry,itedge,jb)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(*) :: jb
            integer(kind=iknd),
     +          dimension(nvf+nb2-nb1+1+3*(nt2-nt1+1)) :: list
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       this routine makes the itedge array for the level 1 elements
c
        do i=1,nvf
            list(i)=0
        enddo
        llist=nvf+nb2-nb1+1+3*(nt2-nt1+1)
        iptr=nvf+1
        do i=iptr,llist,2
            list(i)=i+2
        enddo
        list(llist-1)=0
        list(llist-2)=0
c
c       first find adjacent triangles
c
        do i=nt1,nt2
            do j=1,3
                j2=index(2,j)
                j3=index(3,j)
                imax=max(itnode(j2,i),itnode(j3,i))
                imin=min(itnode(j2,i),itnode(j3,i))
                kold=imin
   40           k=list(kold)
                if(k<=0) then
c
c       add triangle i, edge j to list
c
                    if(iptr<=0) stop 6666
                    list(kold)=iptr
                    ii=iptr
                    iptr=list(iptr)
                    list(ii)=0
                    list(ii+1)=j+4*i
                else
c
c       check for a common edge
c
                    ii=list(k+1)/4
                    jj=list(k+1)-4*ii
                    j2=index(2,jj)
                    j3=index(3,jj)
                    iimax=max(itnode(j2,ii),itnode(j3,ii))
                    if(imax==iimax) then
                        itedge(j,i)=jj+4*ii
                        itedge(jj,ii)=j+4*i
                        list(kold)=list(k)
                        list(k)=iptr
                        iptr=k
c
c       check geometry
c
c*                      qi=geom(itnode(j,i),imin,imax,vx,vy)
c*                      qk=geom(itnode(jj,ii),imin,imax,vx,vy)
c*                      if(qi*qk>=0.0e0_rknd) stop 7777
                    else
                        kold=k
                        go to 40
                    endif
                endif
            enddo
        enddo
c
c       match boundary data in ibndry
c
        do ib=nb1,nb2
            i=jb(ib)
            kold=min(ibndry(1,i),ibndry(2,i))
            imax=max(ibndry(1,i),ibndry(2,i))
   70       k=list(kold)
            if(k<=0) stop 5555
            ii=list(k+1)/4
            jj=list(k+1)-4*ii
            j2=index(2,jj)
            j3=index(3,jj)
            iimax=max(itnode(j2,ii),itnode(j3,ii))
            if(imax==iimax) then
                itedge(jj,ii)=-i
                list(kold)=list(k)
                list(k)=iptr
                iptr=k
            else
                kold=k
                go to 70
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine binits(ip,rp,vx,vy,sf,itnode,ibndry,t,tl,q,jp,
     +      iclr,ntf,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(*) :: iclr
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), dimension(2) :: tmin,tmax
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(25) :: t,tl
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(10) :: rl
            real(kind=rknd), dimension(3) :: bmin,bmax
cy
            external sxy
c
c       find box containing the solution
c
        call linit(t,q)
        call zoombx(rp,t)
c
        ntr=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        ndf=ip(4)
        mpisw=ip(48)
        irgn=ip(50)
        if(mpisw==1) then
            mpirgn=ip(47)
            if(mpirgn/=0.and.mpirgn==irgn) mpisw=-1
            if(itnode(4,1)==0) mpisw=0
        endif
        icrsn=ip(68)
        do i=1,25
            jp(i)=0
        enddo
        jp(1)=ntf
        jp(8)=ntr
        jp(2)=nvf
        jp(3)=nbf
        jp(24)=ndf
        jp(4)=1
        jp(12)=mpisw
c
        inplsw=0
        jp(9)=inplsw
c
        numbrs=ip(60)
        if(numbrs<0.or.numbrs>10) numbrs=0
        if(mpisw==1.and.numbrs/=7) numbrs=0
        if(icrsn==1.and.numbrs/=7) numbrs=0
        jp(21)=numbrs
        lines=ip(59)
        if(lines/=-1) lines=1
        jp(20)=lines
c
        mxcolr=max(2,ip(51))
        mxcolr=min(4096,mxcolr)
        jp(17)=mxcolr
c
c       compute scaled coordinates
c
        call xybox(nbf,vx,vy,sf,ibndry,bmin,bmax,diam,nrl,rl,sxy)
c
        size=t(14)
        xs=t(15)
        ys=t(16)
        scale=size/max(bmax(1)-bmin(1),bmax(2)-bmin(2))
        t(1)=xs-scale*(bmin(1)+bmax(1))/2.0e0_rknd
        t(2)=ys-scale*(bmin(2)+bmax(2))/2.0e0_rknd
        t(3)=scale
c
c       comput number of colors for the case of triangles
c
        ii=5
        tmin(1)=itnode(5,1)
        tmax(1)=itnode(5,1)
        do i=1,ntf
            tmin(1)=min(itnode(5,i),tmin(1))
            tmax(1)=max(itnode(5,i),tmax(1))
        enddo
c
        jp(5)=tmax(1)-tmin(1)+1
        do i=1,ntf
            iclr(i)=itnode(ii,i)-tmin(1)+1
        enddo
        jp(18)=min(mxcolr,jp(5)+2)
c
        do i=1,25
            tl(i)=t(i)
        enddo
        tl(12)=1.0e0_rknd
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine binitt(lent,ip,rp,itnode,itedge,ibndry,ibedge,
     +      itdof,vx,vy,sf,iclr,kdist,t,tl,q,jp,nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd), dimension(*) :: iclr,kdist
            integer(kind=iknd), save, dimension(6) :: num
            integer(kind=iknd), dimension(3) :: iords
            integer(kind=iknd), dimension(2) :: tmin,tmax
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(8,*) :: itdof
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(lent) :: ht
            real(kind=rknd), dimension(100) :: rp
            real(kind=rknd), dimension(25) :: t,tl
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), save, dimension(3) :: bmin,bmax
            real(kind=rknd), dimension(2) :: val
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
            data num/6*0/
            data bmax/3*0.0e0_rknd/
            data bmin/3*0.0e0_rknd/
c
c       make temporary copies of main data structures for graphics
c
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        ndf=ip(4)
        maxt=ip(83)
        maxv=ip(84)
        ifirst=ip(5)
        mpisw=ip(48)
        nproc=ip(49)
        irgn=ip(50)
        if(mpisw==1) then
            mpirgn=ip(47)
            if(mpirgn/=0.and.mpirgn==irgn) mpisw=-1
            if(itnode(4,1)==0) mpisw=0
        endif
        inplsw=ip(53)
        if(inplsw>7.or.inplsw<0) inplsw=0
        icrsn=ip(68)
        itrgt=ip(69)
        do i=1,ntf
            nproc=max(nproc,itnode(4,i))
            ht(i)=0.0e0_rknd
        enddo
c
c       reduce to elements in region irgn
c
        if(mpisw==1) then
            call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag)
            call cedge5(nbf,itedge,ibedge,1_iknd)
            len=nvf
            call cutr1(len,ntf,nvf,nbf,irgn,itnode,itdof,ibndry,
     +          vx,vy,sf,ht,num,bmin,bmax,ibedge,0_iknd)
        else if(icrsn==1) then
            newnbf=0
            do i=1,nbf
                if(ibndry(4,i)/=0) then
                    newnbf=newnbf+1
                    do j=1,7
                        ibndry(j,newnbf)=ibndry(j,i)
                    enddo
                    ibndry(4,newnbf)=1
                 endif
            enddo
            nbf=newnbf
        endif
        call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag)
c
        call linit(t,q)
        call zoombx(rp,t)
c
        do i=1,25
            jp(i)=0
        enddo
        jp(1)=ntf
        jp(2)=nvf
        jp(3)=nbf
        jp(24)=ndf
        jp(4)=1
        jp(23)=nproc
        jp(12)=mpisw
c
        jp(9)=inplsw
c
        numbrs=ip(60)
        if(numbrs<0.or.numbrs>10) numbrs=0
        if(mpisw==1.and.numbrs/=7) numbrs=0
        if(icrsn==1.and.numbrs/=7) numbrs=0
        jp(21)=numbrs
        lines=ip(59)
        if(lines<-1.or.lines>2) lines=0
        if(icrsn==1.and.lines==0) lines=1
        jp(20)=lines
c
        mxcolr=max(2,ip(51))
        mxcolr=min(4096,mxcolr)
        jp(17)=mxcolr
c
c       compute scaled coordinates
c
        call xybox(nbf,vx,vy,sf,ibndry,bmin,bmax,diam,nrl,rl,sxy)
c
        if(mpisw==1) then
            call exbox(bmin,bmax,2_iknd)
            diam=sqrt((bmax(1)-bmin(1))**2+(bmax(2)-bmin(2))**2)
        endif
c
        size=t(14)
        xs=t(15)
        ys=t(16)
        scale=size/max(bmax(1)-bmin(1),bmax(2)-bmin(2))
        t(1)=xs-scale*(bmin(1)+bmax(1))/2.0e0_rknd
        t(2)=ys-scale*(bmin(2)+bmax(2))/2.0e0_rknd
        t(3)=scale
c
c
c       comput number of colors for the case of triangles
c
        if(inplsw>=2.and.inplsw<=5) then
            jp(5)=6
            call tinit(diam,jp,itnode,iclr,vx,vy,num,val)
c
            if(mpisw==1) call exqual(num,val)
c
            t(21)=100.0e0_rknd*real(num(1),rknd)/real(num(4),rknd)
            t(22)=100.0e0_rknd*real(num(2),rknd)/real(num(4),rknd)
            t(23)=100.0e0_rknd*real(num(3),rknd)/real(num(4),rknd)
            t(24)=abs(val(1))
            t(25)=val(2)/real(num(4),rknd)
        else if(inplsw==7) then
            ncolor=min(ip(56),mxcolr-2)
            ncolor=max(1,ncolor)
            jp(5)=ncolor
c
c       element diameter
c
            do i=1,ntf
                ht(i)=ch(itnode(1,i),itnode(2,i),
     +              itnode(3,i),vx,vy)/diam
            enddo
c
            ii=0
            if(ncolor>0) ii=1
            bmin(3)=ht(1)
            bmax(3)=ht(1)
            do i=1,ntf
                iclr(i)=ii
                bmin(3)=min(ht(i),bmin(3))
                bmax(3)=max(ht(i),bmax(3))
            enddo
c
            if(mpisw==1) call exbox(bmin(3),bmax(3),1_iknd)
c
            if(rp(7)<=rp(6)) then
                t(19)=bmin(3)
                t(20)=bmax(3)
            else
                t(19)=rp(6)
                t(20)=rp(7)
            endif
c
            iscale=ip(58)
            if(t(19)<=0.0e0_rknd) iscale=2
            jp(19)=iscale
            zmin=fscale(t(19),iscale,0_iknd)
            zmax=fscale(t(20),iscale,0_iknd)
            if(zmax>zmin) then
                dd=real(ncolor,rknd)/(zmax-zmin)
                do i=1,ntf
                    zz=fscale(ht(i),iscale,0_iknd)
                    iq=max(1,int((zz-zmin)*dd)+1)
                    iclr(i)=min(ncolor,iq)
                enddo
            endif
c
            call cdist(jp,t,ht,kdist)
            nn=2*min(ncolor,11)
            if(mpisw==1) call exdist(kdist,nn)
            jp(6)=1
        else if(inplsw==1) then
            jp(5)=nproc
            jp(7)=0
c
            do i=1,ntf
                iclr(i)=max(0,itnode(4,i))
            enddo
        else if(inplsw==6) then
            mxord=10
            jp(5)=mxord
            jp(7)=0
c
            if(ifirst==0) then
                do i=1,ntf
                  call locord(i,ndof,iord,iords,itdof)
                  iclr(i)=iord
                enddo
            else
                ii=max(ifirst,1_iknd)
                ii=min(ii,mxord)
                do i=1,ntf
                  iclr(i)=ii
                enddo
            endif
c
            call cdist1(jp,iclr,kdist)
            if(mpisw==1) call exdist(kdist,mxord)
        else
            ii=5
            tmin(1)=itnode(5,1)
            tmax(1)=itnode(5,1)
            do i=1,ntf
                tmin(1)=min(itnode(5,i),tmin(1))
                tmax(1)=max(itnode(5,i),tmax(1))
            enddo
c
            if(mpisw==1) call exibox(tmin,tmax,1_iknd)
c
            jp(5)=tmax(1)-tmin(1)+1
            do i=1,ntf
                iclr(i)=itnode(ii,i)-tmin(1)+1
            enddo
        endif
        jp(18)=min(mxcolr,jp(5)+2)
c
        do i=1,25
            tl(i)=t(i)
        enddo
        tl(12)=1.0e0_rknd
c
c       coarsen the mesh
c
        if(icrsn==1) then
c
            call crsn0(nvf,ntf,nbf,itnode,ibndry,itdof,vx,vy,
     +          sf,nrl,rl,itedge,ibedge,iclr,maxv,maxt,nproc,sxy)
            call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,iflag)
c
            if(mpisw==1) then
                ndtrgt=max(3,itrgt/nproc)
            else
                ndtrgt=max(3,itrgt)
            endif
            if(inplsw<6.or.nvf<=ndtrgt) go to 20
c
            itmax=10
            do itnum=1,itmax
                if(itnum<=1) then
                    call smth1(ntf,itedge,iclr)
                else
                    call smth2(ntf,itedge,itnode,vx,vy,iclr)
                endif
                call crsn0(nvf,ntf,nbf,itnode,ibndry,itdof,vx,vy,
     +              sf,nrl,rl,itedge,ibedge,iclr,maxv,maxt,
     1              nproc,sxy)
                call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,
     +                  ibedge,iflag)
                if(nvf<=ndtrgt) exit
            enddo
        endif
c
   20   jp(1)=ntf
        jp(2)=nvf
        jp(3)=nbf
        jp(24)=ndf
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cutr1(mlen,ntf,nvf,nbf,irgn,itnode,itdof,ibndry,
     +      vx,vy,sf,e,iuvptr,ut,vt,ibedge,isw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(2,*) :: ibedge,iuvptr
            integer(kind=iknd), dimension(mlen) :: mark
            integer(kind=iknd), save, dimension(3,3) :: index
            real(kind=rknd), dimension(*) :: vx,vy,e,ut,vt
            real(kind=rknd), dimension(2,*) :: sf
cy
            data index/1,2,3,2,3,1,3,1,2/
c
c       mark edges
c
        newnbf=0
        do i=1,nbf
            kk=0
            if(ibndry(4,i)/=0) then
                k1=ibedge(1,i)/4
                krgn=itnode(4,k1)
                if(krgn==irgn) kk=ibedge(1,i)
            else
                k1=ibedge(1,i)/4
                k2=ibedge(2,i)/4
                k1rgn=itnode(4,k1)
                k2rgn=itnode(4,k2)
                j1rgn=itnode(5,k1)
                j2rgn=itnode(5,k2)
                if(k1rgn==irgn.and.k2rgn/=irgn) kk=ibedge(1,i)
                if(k1rgn/=irgn.and.k2rgn==irgn) kk=ibedge(2,i)
            endif
            if(kk/=0) then
                newnbf=newnbf+1
                do j=1,7
                    ibndry(j,newnbf)=ibndry(j,i)
                enddo
                do j=1,2
                    sf(j,newnbf)=sf(j,i)
                enddo
                kt=kk/4
                ke=kk-4*kt
                if(ibndry(1,newnbf)/=itnode(index(2,ke),kt)) then
                    ii=ibndry(1,newnbf)
                    ibndry(1,newnbf)=ibndry(2,newnbf)
                    ibndry(2,newnbf)=ii
                    if(ibndry(3,newnbf)<0) then
                        ss=sf(1,newnbf)
                        sf(1,newnbf)=sf(2,newnbf)
                        sf(2,newnbf)=ss
                    endif
                endif
                if(ibndry(4,newnbf)==0) then
                    ibndry(4,newnbf)=3
                    if(j1rgn/=j2rgn) ibndry(4,newnbf)=4
                else if(ibndry(4,newnbf)<0) then
                    ibndry(4,newnbf)=1
                endif
            endif
        enddo
c
c       order triangles in region irgn first
c
        newntf=0
        do i=1,ntf
            if(itnode(4,i)/=irgn) cycle
            newntf=newntf+1
            do j=1,5
                itnode(j,newntf)=itnode(j,i)
            enddo
            do j=1,8
                itdof(j,newntf)=itdof(j,i)
            enddo
            if(isw==1) then
                iuvptr(1,newntf+1)=iuvptr(1,newntf)
     +              +iuvptr(1,i+1)-iuvptr(1,i)
                iuvptr(2,newntf)=iuvptr(2,i)
                js=iuvptr(1,i)-iuvptr(1,newntf)
                do j=iuvptr(1,newntf),iuvptr(1,newntf+1)-1
                    ut(j)=ut(js+j)
                    vt(j)=vt(js+j)
                enddo
            else
                e(newntf)=e(i)
            endif
        enddo
c
c       mark vertices
c
        do i=1,nvf
            mark(i)=0
        enddo
        do i=1,newntf
            do j=1,3
                mark(itnode(j,i))=1
            enddo
        enddo
        newnvf=0
        do i=1,nvf
            if(mark(i)==0) cycle
            newnvf=newnvf+1
            mark(i)=newnvf
            vx(newnvf)=vx(i)
            vy(newnvf)=vy(i)
        enddo
        do i=1,newntf
            do j=1,3
                itnode(j,i)=mark(itnode(j,i))
            enddo
        enddo
        do i=1,newnbf
            do j=1,2
                ibndry(j,i)=mark(ibndry(j,i))
            enddo
        enddo
c
        nvf=newnvf
        ntf=newntf
        nbf=newnbf
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine crsn0(nvf,ntf,nbf,itnode,ibndry,itdof,vx,vy,
     +      sf,nrl,rl,itedge,ibedge,icolor,maxv,maxt,nproc,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(maxv) :: iseed,vtype
            integer(kind=iknd), dimension(maxt) :: p,q,mark,list
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(*) :: icolor
            integer(kind=iknd), dimension(500) :: elist,tlist,vlist,
     +          blist,elist0,tlist0,vlist0,blist0
            integer(kind=iknd), dimension(3) :: ibmptr,iv
            integer(kind=iknd), dimension(8,*) :: itdof
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(3) :: bump,e,gf
            real(kind=rknd), dimension(maxt) :: qual
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
c
c       check to see if we have solved problem on current finest grid
c
        angmin=1.0e-3_rknd
        arcmax=0.26e0_rknd
        do i=1,ntf
            itnode(4,i)=itnode(4,i)+(nproc+1)*icolor(i)
        enddo
        iedge=0
c
c       initailize iseed, vtype
c
        call cvtype(ntf,nbf,nvf,itnode,ibndry,vx,vy,sf,
     +      itedge,ibedge,vtype,iseed,angmin,arcmax)
        call cedge5(nbf,itedge,ibedge,1_iknd)
c
c       initialize qual, p,q
c
        do i=1,ntf
            mark(i)=0
            p(i)=i
            q(i)=i
            call rmtst(i,iedge,itnode,itedge,ibndry,
     +          ibedge,vx,vy,iseed,vtype,0_iknd)
            if(iedge>0) then
                qual(i)=1.0e0_rknd
            else
                qual(i)=0.0e0_rknd
            endif
        enddo
c
c       initialize heap
c
        nn=ntf/2
        do k=nn,1,-1
            call updhp(k,nvf,p,q,qual,0_iknd)
        enddo
        last=ntf
c
c       main elimination loop
c
        do nn=ntf,1,-1
            i=p(1)
            if(qual(i)==0.0e0_rknd) exit
            p(1)=p(last)
            p(last)=i
            q(p(last))=last
            q(p(1))=1
            last=last-1
            call updhp(1_iknd,last,p,q,qual,0_iknd)
c
            call rmtst(i,iedge,itnode,itedge,ibndry,
     +          ibedge,vx,vy,iseed,vtype,0_iknd)
            if(iedge==0) stop 6266
            call rmknot(iedge,i,iv,itnode,itedge,ibndry,
     +          ibedge,itdof,vx,vy,sf,1_iknd,ngf,3_iknd,gf,ibmptr,
     1          bump,1_iknd,e,iseed,vtype,incdf,0_iknd,nrl,rl,sxy)
            jtri=iv(3)
            if(jtri>0) then
                kk=q(jtri)
                if(kk==last) then
                    last=last-1
                else
                    p(kk)=p(last)
                    p(last)=jtri
                    q(p(last))=last
                    q(p(kk))=kk
                    last=last-1
                    call updhp(kk,last,p,q,qual,1_iknd)
                endif
            endif
c
c       update vertices in connected to i
c
            llen=0
            do m=1,2
                if(iv(m)==0) cycle
c
                call cirlst(iv(m),itnode,itedge,ibndry,ibedge,
     +              iseed,vtype,vlist,tlist,elist,blist,len)
                call tstvty(iv(m),itnode,ibndry,vx,vy,sf,itedge,
     +              vtype,angmin,arcmax,vlist,tlist,elist,len)
                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,itedge,
     +                  vtype,angmin,arcmax,vlist0,tlist0,elist0,len0)
                    js=1
                    if(vtype(j)>=7) js=2
                    do kk=js,len0
                        k=tlist0(kk)
                        if(mark(k)/=nn) then
                            llen=llen+1
                            list(llen)=k
                            mark(k)=nn
                        endif
                    enddo
                enddo
            enddo
            do m=1,llen
                j=list(m)
                call rmtst(j,iedge,itnode,itedge,ibndry,
     +              ibedge,vx,vy,iseed,vtype,0_iknd)
                if(iedge>0) then
                    qual(j)=1.0e0_rknd
                else
                    qual(j)=0.0e0_rknd
                endif
                kk=q(j)
                call updhp(kk,last,p,q,qual,1_iknd)
            enddo
        enddo
c
        do i=1,ntf
            itnode(4,i)=itnode(4,i)-(nproc+1)*icolor(i)
        enddo
        call clnup0(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge,vx,vy,
     +      sf,icolor,iseed)
c
c       improve geometry
c
        call cedge1(nvf,ntf,nbf,itnode,ibndry,itedge,ibedge,jflag)
        call cedge5(nbf,itedge,ibedge,1_iknd)
        call eswapa(ntf,nvf,nbf,1_iknd,1_iknd,itnode,itedge,ibndry,
     +      ibedge,vx,vy,ibmptr,bump,1_iknd,e,
     1      0_iknd,0_iknd,itdof,1_iknd,e)
        call cedge5(nbf,itedge,ibedge,0_iknd)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine clnup0(nvf,ntf,nbf,itnode,itedge,ibndry,ibedge,
     +      vx,vy,sf,icolor,mark)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(2,*) :: ibedge
            integer(kind=iknd), dimension(*) :: mark,icolor
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
cy
c       clean up data structure after vertex elimination
c
c       fixup itnode, itedge, bump
c
        ntnew=0
        do i=1,ntf
            if(itnode(1,i)/=0) then
                ntnew=ntnew+1
                mark(i)=ntnew
                do j=1,5
                    itnode(j,ntnew)=itnode(j,i)
                enddo
                do j=1,3
                    itedge(j,ntnew)=itedge(j,i)
                enddo
                icolor(ntnew)=icolor(i)
            else
                mark(i)=0
            endif
        enddo
        do i=1,nbf
           ibedge(1,i)=0
           ibedge(2,i)=0
        enddo
        do i=1,ntnew
            do j=1,3
                if(itedge(j,i)>0) then
                    k=itedge(j,i)/4
                    ke=itedge(j,i)-4*k
                    itedge(j,i)=4*mark(k)+ke
                else
                    m=-itedge(j,i)
                    if(ibedge(1,m)>0) then
                        ibedge(2,m)=4*i+j
                    else
                        ibedge(1,m)=4*i+j
                    endif
                endif
            enddo
        enddo
        ntf=ntnew
c
c       fixup ibndry...note internal interface edges are put in itedge
c
        nbnew=0
        do i=1,nbf
            if(ibndry(1,i)/=0) then
                nbnew=nbnew+1
                mark(i)=nbnew
                do j=1,7
                    ibndry(j,nbnew)=ibndry(j,i)
                enddo
                do j=1,2
                    ibedge(j,nbnew)=ibedge(j,i)
                    sf(j,nbnew)=sf(j,i)
                enddo
                k=ibedge(1,nbnew)/4
                ke=ibedge(1,nbnew)-4*k
                itedge(ke,k)=-nbnew
                if(ibedge(2,nbnew)>0) then
                    k=ibedge(2,nbnew)/4
                    ke=ibedge(2,nbnew)-4*k
                    itedge(ke,k)=-nbnew
                endif
            else
                mark(i)=0
            endif
        enddo
        nbf=nbnew
c
c       periodic edges
c
        do i=1,nbf
            if(ibndry(4,i)>=0) cycle
            k=-ibndry(4,i)
            ibndry(4,i)=-mark(k)
        enddo
c
c       now fix vertex arrays
c
        do i=1,nvf
            mark(i)=0
        enddo
        do i=1,ntf
            do j=1,3
                mark(itnode(j,i))=1
            enddo
        enddo
        nvnew=0
        do i=1,nvf
            if(mark(i)/=0) then
                nvnew=nvnew+1
                mark(i)=nvnew
                vx(nvnew)=vx(i)
                vy(nvnew)=vy(i)
            endif
        enddo
        nvf=nvnew
        do i=1,ntf
            do j=1,3
                itnode(j,i)=mark(itnode(j,i))
            enddo
        enddo
        do i=1,nbf
            do j=1,2
                ibndry(j,i)=mark(ibndry(j,i))
            enddo
        enddo
c
c       orient triangles
c
        do i=1,ntf
            r=geom(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy)
            if(r<0.0e0_rknd) then
                itemp=itnode(2,i)
                itnode(2,i)=itnode(3,i)
                itnode(3,i)=itemp
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine smth1(ntf,itedge,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: icolor
            integer(kind=iknd), dimension(3) :: ic
            integer(kind=iknd), dimension(3,*) :: itedge
cy
        itmax=2
c
        do itnum=1,itmax
            ichng=0
            do i=1,ntf
                num=0
                do j=1,3
                    if(itedge(j,i)<=0) cycle
                    num=num+1
                    ii=itedge(j,i)/4
                    ic(num)=icolor(ii)
                enddo
                ii=icolor(i)
                if(num==2) then
                    if(ic(1)==ic(2).and.ii/=ic(1)) then
                        ichng=ichng+1
                        icolor(i)=ic(1)
                    endif
                else if(num==3) then
                    isw=0
                    if(ic(1)==ic(2)) isw=isw+1
                    if(ic(1)==ic(3)) isw=isw+1
                    if(isw>0.and.ii/=ic(1)) then
                        ichng=ichng+1
                        icolor(i)=ic(1)
                    else if(ic(2)==ic(3).and.ii/=ic(2)) then
                        ichng=ichng+1
                        icolor(i)=ic(2)
                    endif
                else if(num==1) then
                    if(ii/=ic(1)) then
                        ichng=ichng+1
                        icolor(i)=ic(1)
                    endif
                endif
            enddo
            if(ichng==0) return
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine smth2(ntf,itedge,itnode,vx,vy,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: icolor
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(5,*) :: itnode
            real(kind=rknd), dimension(*) :: vx,vy
cy
        itmax=1
        theta=0.05e0_rknd
c
        hmin=ch(itnode(1,1),itnode(2,1),itnode(3,1),vx,vy)
        hmax=hmin
        do i=1,ntf
            hh=ch(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy)
            hmin=min(hh,hmin)
            hmax=max(hh,hmax)
        enddo
        thrsh=hmin+theta*(hmax-hmin)
c
        do itnum=1,itmax
            do i=1,ntf
                hh=ch(itnode(1,i),itnode(2,i),itnode(3,i),vx,vy)
                if(hh<=thrsh) then
                    num=2
                    q=real(2*icolor(i),rknd)+0.5e0_rknd
                    do j=1,3
                        if(itedge(j,i)<=0) cycle
                        num=num+2
                        ii=itedge(j,i)/4
                        q=q+real(icolor(ii)+icolor(i),rknd)
                    enddo
                    q=q/real(num,rknd)
                    icolor(i)=int(q)
                endif
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine tplot(vx,vy,ibndry,itnode,sf,t,jp,itedge,iclr,
     +      nrl,rl,sxy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(3,*) :: itedge
            integer(kind=iknd), dimension(25) :: jp
            integer(kind=iknd) :: ccolor
            integer(kind=iknd), dimension(*) :: iclr
            integer(kind=iknd), save, dimension(3,3) :: index
            integer(kind=iknd), dimension(3072) :: ibdy
            integer(kind=iknd), save, dimension(2,1) :: iuvptr
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(2) :: x,y,z
            real(kind=rknd), dimension(3,3) :: q
            real(kind=rknd), dimension(3) :: bx,by,bz,ut,vt
            real(kind=rknd), dimension(3072) :: xp,yp,up,vp
            real(kind=rknd), dimension(10) :: rl
cy
            external sxy
            data index/1,2,3,2,3,1,3,1,2/
            data iuvptr/2*0/
c
c       draw triangle data
c
        ntf=jp(1)
        lines=jp(20)
c
        xshift=t(1)
        yshift=t(2)
        zshift=t(5)
        scale=t(3)
        zval=0.0e0_rknd
c
        do i=1,3
            do j=1,3
                q(i,j)=0.0e0_rknd
            enddo
            q(i,i)=1.0e0_rknd
        enddo
c
c       color triangles
c
        do ii=1,ntf
c
c     compute triangle boundary
c
            call tbdy(xp,yp,up,vp,ibdy,ntri,ii,itnode,ibndry,itedge,
     +          vx,vy,sf,q,0_iknd,-1_iknd,iuvptr,ut,vt,nrl,rl,sxy)
            ic=iclr(ii)
            icolor=ccolor(ic,0_iknd,jp)
            do itri=1,3*ntri,3
                do mm=1,3
                    m=mm+itri-1
                    xx=xp(m)
                    yy=yp(m)
                    bx(mm)=xx*scale+xshift
                    by(mm)=yy*scale+yshift
                    bz(mm)=zval*scale+zshift
                enddo
                call pwindw(bx,by,bz,3_iknd,t,icolor)
c
c        line drawing
c
                do m=1,3
                    k=ibdy(itri+m-1)
                    isw=0
                    if(lines==-1) then
                        isw=1
                    else if(lines==0.and.k>=0) then
                        isw=1
                    else if(k==1) then
                        isw=1
                    else if(k>1) then
                        if(lines==1) then
                            if(k==2.or.k==5) isw=1
                        else if(lines==2) then
                            if(k==3.or.k==5) isw=1
                        endif
                    endif
                    if(isw==1) then
                        x(1)=bx(index(2,m))
                        y(1)=by(index(2,m))
                        z(1)=bz(index(2,m))
                        x(2)=bx(index(3,m))
                        y(2)=by(index(3,m))
                        z(2)=bz(index(3,m))
                        call lwindw(x,y,z,2_iknd,t,2_iknd)
                    endif
                enddo
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sfix(list,length,val,ndig)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd) :: mlen
            character(len=*) :: list
            character(len=1), save :: zero='0',minus='-',dot='.'
            character(len=100) :: temp
cy
c       compute character string for fixed point number
c
        if(val==0.0e0_rknd) then
            length=ndig+1
            do i=1,length
                list(i:i)=zero
            enddo
            list(2:2)=dot
            return
        endif
        zc=abs(val)
        zz=log10(zc)
        iex=int(zz)
        mdig=min(ndig,ndig-iex)
        mdig=max(0,mdig)
        tt=zc*(10.0e0_rknd**mdig)+0.5e0_rknd
        n=int(tt)
        if(n==0) then
            do i=1,ndig+2
                list(i:i)=zero
            enddo
            if(val>=0.0e0_rknd) then
                length=ndig+1
                list(2:2)=dot
            else
                length=ndig+2
                list(1:1)=minus
                list(3:3)=dot
            endif
            return
        endif
        call sint(temp,mlen,n)
        if(mlen<=ndig) then
            do i=mlen,1,-1
                temp(ndig-mlen+i+1:ndig-mlen+i+1)=temp(i:i)
            enddo
            do i=1,ndig+1-mlen
                temp(i:i)=zero
            enddo
            mlen=ndig+1
        endif
        if(val>0.0e0_rknd) then
            length=mlen+1
            ishift=0
        else
            length=mlen+2
            ishift=1
            list(1:1)=minus
        endif
        do i=1,mlen-mdig
            list(i+ishift:i+ishift)=temp(i:i)
        enddo
        ishift=ishift+1
        list(mlen-mdig+ishift:mlen-mdig+ishift)=dot
        do i=mlen-mdig+1,mlen
            list(i+ishift:i+ishift)=temp(i:i)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine htext(xl,yl,xr,yr,nchr,cchr,ijust,q,t,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(80) :: ichr
            integer(kind=iknd), save, dimension(640) :: symbcd
            integer(kind=iknd), save, dimension(94) :: istart
            integer(kind=iknd), save, dimension(128) :: map
            real(kind=rknd), save, dimension(94) :: width
            real(kind=rknd), dimension(2) :: x,y,z
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(3,3) :: q
            character(len=*) :: cchr
            character(len=1) :: cc
cy
c       writes text given in cchr array in the rectangle defined by its
c       lower left corner of world coordinates xl,yl and its upper right
c       corner of world coordinates xr,yr.
c
c       ijust=-1  for justification on the left
c       ijust= 0  for centered text
c       ijust=+1  for justification on the right
c
c        the symbol numbers are
c        1-26   upper case roman simplex
c       27-52   lower case roman simplex
c       53-62   simplex numbers
c       63-78   symbols + - ( ) , . / = * $ < > { } @ ^
c       79-94   symbols [ ] # : ; ! ? % & ~ " ' _ \ | `
c
c
c       symbol parameters taken from n.m.wolcott, fortran iv enhanced
c       character graphics, nbs
c       ichr(j) contains the symbol number of the jth symbol
c       everything outside this range is considered a space
c
        data (symbcd(i),i=1,60)/
     +  443556555,443557579,432612882,        0,433070987,433071584,
     1  323987166,328083226,325854871,317404054,317400725,325723922,
     2  327657165,323364299,298156032,462268125,321889760,309339231,
     3  300852123,296493907,298329038,304489675,317040204,325527312,
     4          0,433070987,433071456,319792797,325953304,327788240,
     5  323429900,312845195,        0,433070987,433071840,432743830,
     6  432383691,        0,433070987,433071840,432743830,        0,
     7  462268125,321889760,309339231,300852123,296493907,298329038,
     8  304489675,317040204,325527312,327792083,327778304,433070987,
     9  462432011,432744214,        0,433070987,        0,449848720/
        data (symbcd(i),i=61,120)/
     +  312911116,306553867,298197837,294134546,        0,433070987,
     1  462431122,443262731,        0,433070987,432383627,        0,
     2  433070987,433071499,466625931,466626443,        0,433070987,
     3  433071883,462432011,        0,443556959,300852123,296493907,
     4  298329038,304489675,317040204,325527312,329885528,328050397,
     5  321889760,309329920,433070987,433071584,323987166,328083225,
     6  325822102,317367189,        0,443556959,300852123,296493907,
     7  298329038,304489675,317040204,325527312,329885528,328050397,
     8  321889760,309343631,327450624,433070987,433071584,323987166,
     9  328083226,325854871,317399958,447424267,        0,460236383/
        data (symbcd(i),i=121,180)/
     +  315630752,300917597,296592281,300688471,317367892,323593937,
     1  325527116,314942603,300294990,        0,441459851,426780256,
     2          0,433070993,300360780,310748555,321267406,327722784,
     3          0,426779851,460334283,        0,428876875,449848395,
     4  449849035,470820555,        0,430974667,460333899,        0,
     5  426779862,308655840,309002240,460333899,430974688,430286539,
     6          0,455910987,455812568,313304217,302785430,296330065,
     7  298263564,306554187,317072974,        0,433070987,432743448,
     8  307012953,317466198,323593873,321332684,312845451,302392206,
     9          0,455812568,313304217,302785430,296330065,298263564/
        data (symbcd(i),i=181,240)/
     +  306554187,317072974,        0,456140363,455812568,313304217,
     1  302785430,296330065,298263564,306554187,317072974,        0,
     2  430548563,321562135,317465945,307012632,298525523,296264590,
     3  302392459,312845772,321323008,445654176,303014876,300266265,
     4  309100544,455910985,318973381,312616068,302167638,317465945,
     5  307012632,298525523,296264590,302392459,312845772,321323008,
     6  433070987,432710744,309110169,319563349,321224704,430973855,
     7  300950433,296760217,298156032,435168287,305144865,300954649,
     8  302261189,295838404,        0,433070987,453813135,441034315,
     9          0,433070987,        0,432841611,432710744,309110169/
        data (symbcd(i),i=241,300)/
     +  319563349,321238613,327952281,338471128,344631563,        0,
     1  432841611,432710744,309110169,319563349,321224704,441230360,
     2  298525523,296264590,302392459,312845772,321332881,323593814,
     3  317465945,307003392,432841604,432743448,307012953,317466198,
     4  323593873,321332684,312845451,302392206,        0,455910980,
     5  455812568,313304217,302785430,296330065,298263564,306554187,
     6  317072974,        0,432841611,432645078,304882905,315392000,
     7  453715416,311207001,298591062,298460179,313075153,319268366,
     8  317072651,304456588,296157184,435168207,302392459,310752025,
     9  309100544,432841615,300295243,310748556,321369689,321224704/
        data (symbcd(i),i=301,360)/
     +  428647563,453813387,        0,430744651,447521867,447522379,
     1  464299595,        0,430745099,453813067,        0,428647563,
     2  453813387,302228357,293741252,        0,453813067,430745113,
     3  430286347,        0,443556895,298722135,296362895,302392523,
     4  312845836,323462868,325822108,319792480,309329920,437134493,
     5  313533771,        0,432907164,300885023,307242400,319792734,
     6  323888794,321660373,296068811,        0,435168928,311174616,
     7  321627798,325691089,323429900,312845451,300295053,296189952,
     8  451945298,327759328,317030400,456139744,298558424,307012953,
     9  319563414,325691089,323429900,312845451,300295053,296189952/
        data (symbcd(i),i=361,420)/
     +  458139231,315630880,305112028,298558354,300360780,310748491,
     1  319170190,325625554,323659287,313271576,304849877,298385408,
     2  460334155,430974688,        0,441459679,298754971,300721240,
     3  313239062,323626706,325559949,321267083,306553804,298230607,
     4  296297364,302720215,317466201,323856029,321889696,307232768,
     5  458008150,317334803,308913172,298525529,296559517,303015136,
     6  311436767,321824409,323626575,317072651,306553804,298254336,
     7  451847627,432678932,        0,432678932,        0,447882466,
     8  305112027,298525586,300328009,308487492,        0,431104994,
     9  305112283,311108882,308716617,300098372,        0,436609995/
        data (symbcd(i),i=421,480)/
     +  298197965,302392330,300163975,        0,434545548,300262412,
     1  300318720,466756356,        0,432777239,432580625,        0,
     2  441263246,430679505,451650385,        0,441590919,449979783,
     3  460236383,315630752,300917597,296592281,300688471,317367892,
     4  323593937,325527116,314942603,300294990,        0,466527124,
     5  331710464,432973716,298156032,443688035,303113184,300885020,
     6  304981145,306947093,439460897,303015005,307111130,309077142,
     7  298460306,308815054,306586699,302294023,304264211,306750607,
     8  304522252,300229576,302195781,308412416,435299427,307307744,
     9  309273756,304981017,302752917,439461025,307209309,302916570/
        data (symbcd(i),i=481,540)/
     +  300688406,311043090,300426190,302392395,306488455,304264339,
     1  302556175,304522380,308618440,306390085,300023808,462169818,
     2  321758619,311239897,306914451,308847952,319301265,325694875,
     3  311207126,308913425,313014043,325691089,329787344,338241685,
     4  340502618,336471966,328181344,315630815,305079260,298656599,
     5  296362897,300393549,308684171,321234700,331786190,464365331,
     6  327722832,        0,426321109,325661394,309012178,        0,
     7  433202052,435299268,433202532,432153924,        0,443688132,
     8  445785348,431105316,430056708,        0,447751044,460334340,
     9  432711445,430417615,        0,434938776,300655640,300725197/
        data (symbcd(i),i=541,600)/
     +  298197963,302392269,        0,434938776,300655640,300725195,
     1  298197965,302392330,300163975,        0,435168158,300491806,
     2  300954590,300692429,298197963,302392269,        0,432939995,
     3  298656603,296625054,300917856,311436767,319759964,321725976,
     4  317433045,308884768,315598302,319694362,317465942,442934412,
     5  308651276,308707328,468722507,441459998,311305434,304915417,
     6  296592221,298820640,307242271,317662878,330278880,459875921,
     7  319268365,323331851,331753422,333981522,325648384,468461463,
     8  334178327,336340953,332179288,327886481,319235468,310748235,
     9  298197838,296264595,311141785,317564381,315598112,307209309/
        data (symbcd(i),i=601,640)/
     +  304981144,311076430,325461899,333817868,335983691,300295054,
     1  298361811,304788571,307013262,327559051,        0,430482259,
     2  298525719,306947350,319399570,327755667,334148435,298492950,
     3  306914581,319366801,327722898,334145495,        0,435168153,
     4  437265305,451945881,454043033,        0,443557017,445654169,
     5          0,432351242,        0,429008772,        0,439493700,
     6          0,430973849,428876697,        0/
c
        data istart/
     +     1,   5,  16,  26,  34,  39,  43,  54,  58,  60,  66,  70,
     1    73,  78,  82,  93, 100, 112, 120, 131, 134, 140, 143, 148,
     2   151, 154, 158, 167, 176, 184, 193, 202, 206, 217, 222, 226,
     3   232, 236, 238, 247, 252, 261, 270, 279, 283, 292, 296, 301,
     4   304, 309, 312, 317, 321, 330, 333, 341, 349, 352, 361, 373,
     5   376, 391, 403, 406, 408, 414, 420, 425, 428, 430, 433, 437,
     6   450, 452, 454, 473, 492, 519, 523, 528, 533, 538, 544, 551,
     7   558, 573, 588, 612, 624, 629, 632, 634, 636, 638/
c
        data (width(i),i=1,40)/
     +  18.0e0_rknd,21.0e0_rknd,21.0e0_rknd,21.0e0_rknd,
     1  19.0e0_rknd,18.0e0_rknd,21.0e0_rknd,22.0e0_rknd,
     2   8.0e0_rknd,16.0e0_rknd,21.0e0_rknd,17.0e0_rknd,
     3  24.0e0_rknd,22.0e0_rknd,22.0e0_rknd,21.0e0_rknd,
     4  22.0e0_rknd,21.0e0_rknd,20.0e0_rknd,16.0e0_rknd,
     5  22.0e0_rknd,18.0e0_rknd,24.0e0_rknd,20.0e0_rknd,
     6  18.0e0_rknd,20.0e0_rknd,19.0e0_rknd,19.0e0_rknd,
     7  18.0e0_rknd,19.0e0_rknd,18.0e0_rknd,12.0e0_rknd,
     8  19.0e0_rknd,19.0e0_rknd, 8.0e0_rknd,10.0e0_rknd,
     9  17.0e0_rknd, 8.0e0_rknd,30.0e0_rknd,19.0e0_rknd/
        data (width(i),i=41,80)/
     +  19.0e0_rknd,19.0e0_rknd,19.0e0_rknd,13.0e0_rknd,
     1  17.0e0_rknd,12.0e0_rknd,19.0e0_rknd,16.0e0_rknd,
     2  22.0e0_rknd,17.0e0_rknd,16.0e0_rknd,17.0e0_rknd,
     3  20.0e0_rknd,20.0e0_rknd,20.0e0_rknd,20.0e0_rknd,
     4  20.0e0_rknd,20.0e0_rknd,20.0e0_rknd,20.0e0_rknd,
     5  20.0e0_rknd,20.0e0_rknd,26.0e0_rknd,26.0e0_rknd,
     6  14.0e0_rknd,14.0e0_rknd,10.0e0_rknd,10.0e0_rknd,
     7  22.0e0_rknd,26.0e0_rknd,16.0e0_rknd,20.0e0_rknd,
     8  24.0e0_rknd,24.0e0_rknd,14.0e0_rknd,14.0e0_rknd,
     9  27.0e0_rknd,22.0e0_rknd,14.0e0_rknd,14.0e0_rknd/
        data (width(i),i=81,94)/
     +  21.0e0_rknd,10.0e0_rknd,10.0e0_rknd,10.0e0_rknd,
     1  18.0e0_rknd,24.0e0_rknd,25.0e0_rknd,24.0e0_rknd,
     2  16.0e0_rknd, 8.0e0_rknd,26.0e0_rknd,22.0e0_rknd,
     3  14.0e0_rknd, 8.0e0_rknd/
c
            data map/
     +       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     1       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
     2       0,84,89,81,72,86,87,90,65,66,71,63,67,64,68,69,
     3      53,54,55,56,57,58,59,60,61,62,82,83,73,70,74,85,
     4      77, 1, 2, 3, 4, 5, 6, 7, 8, 9,10,11,12,13,14,15,
     5      16,17,18,19,20,21,22,23,24,25,26,79,92,80,78,91,
     6      94,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,
     7      42,43,44,45,46,47,48,49,50,51,52,75,93,76,88, 0/
c
c       ixtrct gets nbits from iword starting at the nstart
c       bit from the right
c
        ixtrct(nstart,nbits,iword)=mod(iword/(2**(nstart-nbits)),
     +      2**nbits)+((1-sign(1_iknd,iword))/2)*
     1      (2**nbits-min(1,mod(-iword,2**(nstart-nbits))))
c
        if(nchr<=0) return
        if(xl>=xr) return
        if(yl>=yr) return
c
        do i=1,nchr
            cc=cchr(i:i)
            ii=ichar(cc)
            ichr(i)=map(ii+1)
        enddo
        dx=xr-xl
        dy=yr-yl
c
c       find width of strings to be plotted
c
        wid=0.0e0_rknd
        do i=1,nchr
            ic=ichr(i)
            if(ic<1.or.ic>94) then
                wid=wid+20.0e0_rknd
            else
                wid=wid+width(ic)
            endif
        enddo
        wid=wid/21.0e0_rknd
c
        height=min(dx/wid,dy)
        if(height<dy) then
            x0=xl
            y0=yl+(dy-height)/2.0e0_rknd
        else
c
c       justification
c
            y0=yl
            if(ijust==-1) then
                x0=xl
            else if(ijust==0) then
                x0=xl+(dx-wid*height)/2.0e0_rknd
            else if(ijust==1) then
                x0=xr-wid*height
            endif
        endif
c
        scale=t(3)
        xshift=t(1)
        yshift=t(2)
        zshift=t(5)
c
        rscale=height/21.0e0_rknd
        xi=x0
        yi=y0
c
        do i=1,nchr
            ic=ichr(i)
            if(ic<=0.or.ic>94) then
c
c        plot a space
c
                xi=xi+20.0e0_rknd*rscale
            else
c
c       plot a single symbol
c
                is=istart(ic)
                ib=30
   70           ipen=ixtrct(ib,3_iknd,symbcd(is))
                if(ipen==0)then
                    xi=xi+rscale*width(ic)
                    cycle
                endif
                ix=ixtrct(ib-3_iknd,6_iknd,symbcd(is))
                iy=ixtrct(ib-9_iknd,6_iknd,symbcd(is))
                xx=xi+(ix-10)*rscale
                yy=yi+(iy-11)*rscale
                xm=xx*q(1,1)+yy*q(2,1)
                ym=xx*q(1,2)+yy*q(2,2)
                zm=xx*q(1,3)+yy*q(2,3)
                xx=xm*scale+xshift
                yy=ym*scale+yshift
                zz=zm*scale+zshift
                if(ipen==2) then
                    x(2)=xx
                    y(2)=yy
                    z(2)=zz
                    call lwindw(x,y,z,2_iknd,t,icolor)
                endif
                x(1)=xx
                y(1)=yy
                z(1)=zz
                ib=45-ib
                if(ib==30)is=is+1
                go to 70
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pwindw(x,y,z,llen,t,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y,z
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(22) :: xn,yn,zn,x0,y0,z0
            real(kind=rknd), dimension(4) :: cx,cy,cc
cy
c       map a polygon onto the current window
c
        rmag=t(12)
        if(rmag<=1.0e0_rknd) then
            call pfill(x,y,z,llen,icolor)
            return
        endif
c
        nmax=22
        eps=t(7)/rmag
        shift=(1.0e0_rknd-t(14))/2.0e0_rknd
c
        cx(1)=1.0e0_rknd
        cx(2)=-cx(1)
        cx(3)=0.0e0_rknd
        cx(4)=cx(3)
c
        cy(1)=cx(3)
        cy(2)=cx(4)
        cy(3)=cx(1)
        cy(4)=cx(2)
c
        cc(1)=-t(8)
        cc(2)=t(9)
        cc(3)=-t(10)
        cc(4)=t(11)
c
        do i=1,llen
            xn(i)=x(i)
            yn(i)=y(i)
            zn(i)=z(i)
        enddo
        num=llen
c
        do k=1,4
            len=num
            num=0
            do i=1,len
                x0(i)=xn(i)
                y0(i)=yn(i)
                z0(i)=zn(i)
            enddo
            do i=1,len
                si=x0(i)*cx(k)+y0(i)*cy(k)+cc(k)
                if(si>=eps) then
                    num=num+1
                    xn(num)=x0(i)
                    yn(num)=y0(i)
                    zn(num)=z0(i)
                else
                    ibef=i-1
                    if(i==1) ibef=len
                    iaft=i+1
                    if(i==len) iaft=1
                    j=ibef
                    do jj=1,2
                        s=x0(j)*cx(k)+y0(j)*cy(k)+cc(k)
                        if(s>eps) then
                            num=num+1
                            f=s/(s-si)
                            xn(num)=x0(i)*f+x0(j)*(1.0e0_rknd-f)
                            yn(num)=y0(i)*f+y0(j)*(1.0e0_rknd-f)
                            zn(num)=z0(i)*f+z0(j)*(1.0e0_rknd-f)
                        endif
                        j=iaft
                    enddo
                endif
            enddo
            if(num<=2) return
            if(num>=nmax-2) stop 7577
        enddo
        do i=1,num
            xn(i)=(xn(i)+cc(1))*rmag+shift
            yn(i)=(yn(i)+cc(3))*rmag+shift
cc          zn(i)=zn(i)*rmag
        enddo
        call pfill(xn,yn,zn,num,icolor)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine lwindw(x,y,z,n,t,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y,z
            real(kind=rknd), dimension(25) :: t
            real(kind=rknd), dimension(2) :: xx,yy,zz
cy
c       draw the part of the picture within the current window
c
        rmag=t(12)
        if(rmag<=1.0e0_rknd) then
            call pline(x,y,z,n,icolor)
            return
        endif
c
        xl=t(8)
        xr=t(9)
        yb=t(10)
        yt=t(11)
        shift=(1.0e0_rknd-t(14))/2.0e0_rknd
c
c       the main loop
c
        do i=2,n
            xx(1)=x(i-1)
            yy(1)=y(i-1)
            zz(1)=z(i-1)
            xx(2)=x(i)
            yy(2)=y(i)
            zz(2)=z(i)
c
c       fit line into window in x direction
c
            jl=1
            if(xx(2)<xx(1)) jl=2
            jr=3-jl
            if(xx(jr)<=xl.or.xx(jl)>=xr) cycle
c
            if(xx(jl)<xl) then
               f=(xx(jr)-xl)/(xx(jr)-xx(jl))
               xx(jl)=xl
               yy(jl)=yy(jl)*f+yy(jr)*(1.0e0_rknd-f)
               zz(jl)=zz(jl)*f+zz(jr)*(1.0e0_rknd-f)
            endif
c
            if(xx(jr)>xr) then
                f=(xr-xx(jl))/(xx(jr)-xx(jl))
                xx(jr)=xr
                yy(jr)=yy(jr)*f+yy(jl)*(1.0e0_rknd-f)
                zz(jr)=zz(jr)*f+zz(jl)*(1.0e0_rknd-f)
            endif
c
c       fit line into window in y direction
c
            jb=1
            if(yy(2)<yy(1)) jb=2
            jt=3-jb
            if(yy(jt)<=yb.or.yy(jb)>=yt) cycle
c
            if(yy(jb)<yb) then
                f=(yy(jt)-yb)/(yy(jt)-yy(jb))
                yy(jb)=yb
                xx(jb)=xx(jb)*f+xx(jt)*(1.0e0_rknd-f)
                zz(jb)=zz(jb)*f+zz(jt)*(1.0e0_rknd-f)
            endif
c
            if(yy(jt)>yt) then
                f=(yt-yy(jb))/(yy(jt)-yy(jb))
                yy(jt)=yt
                xx(jt)=xx(jt)*f+xx(jb)*(1.0e0_rknd-f)
                zz(jt)=zz(jt)*f+zz(jb)*(1.0e0_rknd-f)
            endif
c
c       rescale and then draw
c
            do j=1,2
                xx(j)=(xx(j)-xl)*rmag+shift
                yy(j)=(yy(j)-yb)*rmag+shift
cc              zz(j)=zz(j)*rmag
            enddo
            call pline(xx,yy,zz,2_iknd,icolor)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ascutl(id,fname,mode,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save, dimension(10) :: istack
            integer(kind=iknd), save :: length,ifirst=1,next
            character(len=1) :: mode
            character(len=80), save :: sname
            character(len=80) :: fname
            common /asc/maxid,irw(10),iunit(10)
cy
c       iflag= 0  ok
c              1  error on open
c              2  bad mode (not c,r, or w)
c              3  exceed maxid id's
c              4  invalid id
c              5  file not open
c              6  read error
c              7  write error
c             -1  end of file
c
        if(ifirst==1) then
            maxid=10
            do i=1,maxid
                iunit(i)=20+i
                irw(i)=0
                istack(i)=i+1
            enddo
            istack(maxid)=-1
            next=1
            ifirst=0
        endif
        iflag=0
c
c       close
c
        if(mode=='c') then
c
c       ckeck for valid id
c
            if(id<=0.or.id>maxid) then
                iflag=4
                return
            endif
            if(irw(id)==0) then
                iflag=5
                return
            endif
            irw(id)=0
            istack(id)=next
            next=id
            close(unit=iunit(id))
            return
        endif
c
c       get next available id
c
        if(next>0) then
            id=next
            next=istack(id)
        else
c
c       too many files open
c
            iflag=3
            return
        endif
c
c       process filename
c
        call fstr(sname,length,fname,0_iknd)
c
c       open for write
c
        if(mode=='w') then
            open(unit=iunit(id),form='formatted',status='unknown',
     +          file=sname,access='sequential',err=10)
            irw(id)=1
        else if(mode=='r') then
c
c       open for read
c
            open(unit=iunit(id),form='formatted',status='old',
     +          file=sname,access='sequential',err=10)
            irw(id)=-1
        else
            iflag=2
            go to 20
        endif
        return
c
c       if open failed, restore id to available stack
c
   10   iflag=1
   20   irw(id)=0
        istack(id)=next
        next=id
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ascstr(id,sval,length,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            character(len=*) :: sval
            common /asc/maxid,irw(10),iunit(10)
cy
c       write a character string
c
c       the long formats are to accomodate xpm files
c       normally should be (80a1)
c
        iflag =0
        if(id<=0.or.id>maxid) then
            iflag=4
            return
        endif
        if(irw(id)==0) then
            iflag=5
            return
        endif
        if(irw(id)<0) then
            read(iunit(id),fmt='(2000a1)',end=10,err=20)
     +          (sval(i:i),i=1,length)
        else
            write(iunit(id),fmt='(2000a1)',err=30)
     +          (sval(i:i),i=1,length)
        endif
        flush(iunit(id))
        return
   10   iflag=-1
        return
   20   iflag=6
        return
   30   iflag=7
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ascint(id,ival,length,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ival
            common /asc/maxid,irw(10),iunit(10)
cy
c       write an integer array
c
        iflag =0
        if(id<=0.or.id>maxid) then
            iflag=4
            return
        endif
        if(irw(id)==0) then
            iflag=5
            return
        endif
        if(irw(id)<0) then
            read(iunit(id),fmt='(6(2x,i11))',end=10,err=20)
     +          (ival(i),i=1,length)
        else
            write(iunit(id),fmt='(6(2x,i11))',err=30)
     +          (ival(i),i=1,length)
        endif
        flush(iunit(id))
        return
   10   iflag=-1
        return
   20   iflag=6
        return
   30   iflag=7
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine ascflt(id,rval,length,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: rval
            common /asc/maxid,irw(10),iunit(10)
cy
c       write a real array
c
        iflag =0
        if(id<=0.or.id>maxid) then
            iflag=4
            return
        endif
        if(irw(id)==0) then
            iflag=5
            return
        endif
        if(irw(id)<0) then
            read(iunit(id),fmt='(3(2x,e23.15))',end=10,err=20)
     +          (rval(i),i=1,length)
        else
            write(iunit(id),fmt='(3(2x,e23.15))',err=30)
     +          (rval(i),i=1,length)
        endif
        flush(iunit(id))
        return
   10   iflag=-1
        return
   20   iflag=6
        return
   30   iflag=7
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine rdwrt(fname,isave,vx,vy,sf,ibndry,itnode,itdof,
     +      ipath,e,ip,rp,sp,iu,ru,su,gf)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(7,*) :: ibndry
            integer(kind=iknd), dimension(6,*) :: ipath
            integer(kind=iknd), dimension(5,*) :: itnode
            integer(kind=iknd), dimension(100) :: ip,iu
            integer(kind=iknd), dimension(8,*) :: itdof
            integer(kind=iknd), save :: jfirst=1
            real(kind=rknd), dimension(*) :: vx,vy,e,gf
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(100) :: rp,ru
            real(kind=rknd), dimension(101,6) :: path0
            real(kind=rknd), dimension(22,30) :: hist0
            real(kind=rknd), dimension(3,50) :: time0
            character(len=4) :: keychk,keywrd
            character(len=80) :: fname,sname
            character(len=80), dimension(100) :: sp,su
            common /pltmg7/time(3,50),hist(22,30)
            common /pltmg6/path(101,6)
            common /atest6/nproc,myid,mpisw,mpiint,mpiflt
cy
c       isave =  0, write a file
c       isave =  1, read a file
c
        iflag=0
        sp(11)='rdwrt: ok'
        call stfile(sname,fname)
        if(rknd==rsngl) then
            if(iknd==isngl) then
                keywrd='rwss'
            else
                keywrd='rwds'
            endif
        else if(rknd==rdble) then
            if(iknd==isngl) then
                keywrd='rwsd'
            else
                keywrd='rwdd'
            endif
        else
            if(iknd==isngl) then
                keywrd='rwsq'
            else
                keywrd='rwdq'
            endif
        endif
c
        if(isave==0_iknd) then
            keychk=keywrd
            jfirst=1
            call xdrutl(id,sname,'w',jflag)
        else if(isave==1_iknd) then
            call xdrutl(id,sname,'r',jflag)
        else
            iflag=87
            sp(11)='rdwrt: bad value for isave'
            go to 40
        endif
c
c
        call xdrstr(id,keychk,4,jflag)
        if(keychk/=keywrd) then
            iflag=16
            sp(11)='rdwrt: wrong keyword'
            go to 30
        endif
c
c       integer arrays
c
        if(iknd==isngl) then
            call xdrint(id,ip,100,jflag)
        else
            call xdrlng(id,ip,100,jflag)
        endif
c
        ntf=ip(1)
        nvf=ip(2)
        nbf=ip(3)
        ndf=ip(4)
        ifirst=ip(5)
        maxd=ip(85)
        maxt=ip(83)
        ip(48)=mpisw
        ip(49)=nproc
        ip(50)=myid+1
c
        lipath=ip(72)
        ngf=ip(77)
c
        if(iknd==isngl) then
            call xdrint(id,iu,100,jflag)
            call xdrint(id,itnode,5*ntf,jflag)
            call xdrint(id,ibndry,7*nbf,jflag)
            if(itnode(3,1)/=0.and.ifirst==0) then
                if(lipath>0) call xdrint(id,ipath,6*lipath,jflag)
                call xdrint(id,itdof,8*ntf,jflag)
            endif
        else
            call xdrlng(id,iu,100,jflag)
            call xdrlng(id,itnode,5*ntf,jflag)
            call xdrlng(id,ibndry,7*nbf,jflag)
            if(itnode(3,1)/=0.and.ifirst==0) then
                if(lipath>0) call xdrlng(id,ipath,6*lipath,jflag)
                call xdrlng(id,itdof,8*ntf,jflag)
            endif
        endif
c
c       real arrays
c
        if(rknd==rsngl) then
            call xdrflt(id,rp,100,jflag)
            call xdrflt(id,ru,100,jflag)
            call xdrflt(id,vx,nvf,jflag)
            call xdrflt(id,vy,nvf,jflag)
            call xdrflt(id,sf,2*nbf,jflag)
            if(itnode(3,1)/=0.and.ifirst==0) then
                do k=1,ngf
                    call xdrflt(id,gf((k-1)*maxd+1),ndf,jflag)
                enddo
                if(jfirst==1) then
                    call xdrflt(id,path,606,jflag)
                    call xdrflt(id,hist,660,jflag)
                    call xdrflt(id,time,150,jflag)
                    jfirst=0
                else
                    call xdrflt(id,path0,606,jflag)
                    call fixpth(path,path0)
                    call xdrflt(id,hist0,660,jflag)
                    call fixhst(hist,hist0)
                    call xdrflt(id,time0,150,jflag)
                endif
                do k=1,2
                    call xdrflt(id,e((k-1)*maxt+1),ntf,jflag)
                enddo
            endif
        else if(rknd==rdble) then
            call xdrdbl(id,rp,100,jflag)
            call xdrdbl(id,ru,100,jflag)
            call xdrdbl(id,vx,nvf,jflag)
            call xdrdbl(id,vy,nvf,jflag)
            call xdrdbl(id,sf,2*nbf,jflag)
            if(itnode(3,1)/=0.and.ifirst==0) then
                do k=1,ngf
                    call xdrdbl(id,gf((k-1)*maxd+1),ndf,jflag)
                enddo
                if(jfirst==1) then
                    call xdrdbl(id,path,606,jflag)
                    call xdrdbl(id,hist,660,jflag)
                    call xdrdbl(id,time,150,jflag)
                    jfirst=0
                else
                    call xdrdbl(id,path0,606,jflag)
                    call fixpth(path,path0)
                    call xdrdbl(id,hist0,660,jflag)
                    call fixhst(hist,hist0)
                    call xdrdbl(id,time0,150,jflag)
                endif
                do k=1,2
                    call xdrdbl(id,e((k-1)*maxt+1),ntf,jflag)
                enddo
            endif
        else
            call xdrqud(id,rp,100,jflag)
            call xdrqud(id,ru,100,jflag)
            call xdrqud(id,vx,nvf,jflag)
            call xdrqud(id,vy,nvf,jflag)
            call xdrqud(id,sf,2*nbf,jflag)
            if(itnode(3,1)/=0.and.ifirst==0) then
                do k=1,ngf
                    call xdrqud(id,gf((k-1)*maxd+1),ndf,jflag)
                enddo
                if(jfirst==1) then
                    call xdrqud(id,path,606,jflag)
                    call xdrqud(id,hist,660,jflag)
                    call xdrqud(id,time,150,jflag)
                    jfirst=0
                else
                    call xdrqud(id,path0,606,jflag)
                    call fixpth(path,path0)
                    call xdrqud(id,hist0,660,jflag)
                    call fixhst(hist,hist0)
                    call xdrqud(id,time0,150,jflag)
                endif
                do k=1,2
                    call xdrqud(id,e((k-1)*maxt+1),ntf,jflag)
                enddo
            endif
        endif
c
c       string arrays
c
        call xdrstr(id,sp,8000,jflag)
        call xdrstr(id,su,8000,jflag)
c
   30   call xdrutl(id,sname,'c',jflag)
   40   ip(25)=iflag
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine fixpth(path,path0)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(101,6) :: path0,path
cy
c       compare old and new paths and start a new branch if reasonable
c
        num=int(path(101,1))
        num0=int(path0(101,1))
        if(num0>num) go to 10
        if(num0>1) then
            do i=1,num0-1
                do j=1,6
                    if(path0(i,j)/=path(i,j)) go to 10
                enddo
            enddo
        endif
        if(path0(num0,1)/=path(num0,1)) go to 10
        if(path0(num0,2)/=path(num0,2)) go to 10
        it=int(path(num0,6))
        it0=int(path0(num0,6))
        if(it==it0.and.it/=6) then
            if(path0(num0,3)/=path(num0,3)) go to 10
            if(path0(num0,4)/=path(num0,4)) go to 10
            if(path0(num0,5)/=path(num0,5)) go to 10
        endif
c
c       restore old path
c
        if(num>=100) then
            do i=1,100
                do j=1,6
                    path(i,j)=path(i+1,j)
                enddo
            enddo
            num=100
        else
            num=num+1
        endif
c
c       start a new branch
c
        do j=1,6
            path(num,j)=path0(num0,j)
        enddo
        path(num,6)=real(7,rknd)
        path(101,1)=real(num,rknd)
        return
c
c       restore current path
c
   10   do i=1,num0
            do j=1,6
                path(i,j)=path0(i,j)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine fixhst(hist,hist0)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(22,30) :: hist0,hist
cy
c       compare old and new histray arrays
c
        mxhist=20
        numhst=20
        num=int(hist(mxhist+2,1))
        num0=int(hist0(mxhist+2,1))
        istart=1
        if(num0>num) go to 10
        istart=7
c
c       save error histories
c
        if(num0>1) then
            do i=1,num0
                isw=0
                do j=1,6
                    if(hist0(i,j)/=hist(i,j)) isw=1
                enddo
                if(isw==1) then
                    if(num>=mxhist) then
                        do k=1,mxhist
                            do j=1,6
                                hist(k,j)=hist(k+1,j)
                            enddo
                        enddo
                        num=mxhist
                    else
                        num=num+1
                    endif
                    do j=1,6
                        hist(num,j)=hist0(i,j)
                    enddo
                    hist(mxhist+2,1)=real(num,rknd)
                endif
            enddo
        endif
c
c       restore current history for everything else
c
   10   do i=1,mxhist+2
            do j=istart,numhst
                hist(i,j)=hist0(i,j)
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine reset(num,name,nptr,labels,values,ip,rp,sp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ip,nptr
            integer(kind=isngl), dimension(101) :: sptr
            real(kind=rknd), dimension(*) :: rp
            character(len=15), dimension(*) :: name
            character(len=80), dimension(*) :: sp,labels,values
            character(len=80), dimension(100) :: sval
            character(len=80) :: list,ss,msg
            character(len=1) :: cmd
            character(len=1), dimension(100) :: typ,mark
            character(len=6) :: cmdtyp
            character(len=9), dimension(100) :: tval
            common /atest3/mode,jnlsw,jnlr,jnlw,ibatch
            common /atest4/jcmd,cmdtyp,list
cy
c       reset user paremeters
c
        cmd=list(1:1)
        call lookup(name,num,ip,rp,sp,list,ierr,length)
c
c       print  parameters
c
        if(mode==-1) call disply(name,num,ip,rp,sp)
c
        if(ierr/=0) then
            ss='command error'
            call filutl(ss,0_iknd)
        endif
        if(length>1.and.ierr==0) return
c
c       x-windows display
c
        if(jnlsw==0) then
            do i=1,num
                mark(i)='f'
                sptr(i)=nptr(i)
                call cint(name(i),3_iknd,indx,jerr)
                tval(i)(1:9)=name(i)(5:13)
                if(tval(i)(9:9)==' ') then
                    tval(i)(9:9)=tval(i)(8:8)
                    tval(i)(8:8)=' '
                endif
                typ(i)=name(i)(15:15)
                sval(i)=' '
                if(name(i)(15:15)=='i') then
                    call sint(sval(i),length,ip(indx))
                else if(name(i)(15:15)=='r') then
                    call sreal(sval(i),length,rp(indx),5_iknd,0_iknd)
                else
                    sval(i)=sp(indx)
                endif
            enddo
            sptr(num+1)=nptr(num+1)
c
            if(num==1.and.typ(1)=='f') then
                call xfile(list,sval,tval,jcmd)
                if(sp(indx)/=sval(1)) mark(1)='t'
            else
                call xreset(list,num,typ,sval,mark,tval,
     +              sptr,labels,values,jcmd)
            endif
c
            do i=1,num
                if(mark(i)=='t') then
                    call cint(name(i),3_iknd,indx,jerr)
                    if(name(i)(15:15)=='i') then
                        call cint(sval(i),80_iknd,ival,jerr)
                        if(jerr==0) ip(indx)=ival
                    else if(name(i)(15:15)=='r') then
                        call creal(sval(i),80_iknd,rval,jerr)
                        if(jerr==0) rp(indx)=rval
                    else
                        jerr=0
                        sp(indx)=sval(i)
                    endif
                    if(jerr==0) then
                        ss=' '
                        if(name(i)(15:15)=='l') then
                            call fstr(ss,length,sval(i),1_iknd)
                        else
                            call fstr(ss,length,sval(i),0_iknd)
                        endif
                        write(unit=msg,fmt='(a1,a6,a1,a72)')
     +                      cmd,name(i)(5:10),'=',ss
                        call star0(msg)
                        call filutl(msg,1_iknd)
                    endif
                endif
            enddo
c
        else if(jnlsw/=-2) then
            call getcmd(list)
        endif
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine menu(ip,rp,sp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save, dimension(24) :: st
            integer(kind=iknd), dimension(*) :: ip
            integer(kind=iknd), save, dimension(525) :: iptr
            integer(kind=iknd), save, dimension(301) :: nptr
            integer(kind=iknd), dimension(101) :: sptr
            integer(kind=iknd), save :: iustat,lowera=97,lowerz=122
            integer(kind=iknd), save :: mpibtn=0,ifirst=-1,ncmd
            real(kind=rknd), dimension(*) :: rp
            character(len=1), save, dimension(24) :: sty
            character(len=6) :: cmdtyp
            character(len=15), save, dimension(300) :: name
            character(len=15), dimension(100) :: sname
            character(len=15), save, dimension(24) :: ctable
            character(len=80), dimension(100) :: sp
            character(len=80) :: list,filnam
            character(len=80), save :: ulist
            character(len=80), dimension(500) :: file
            character(len=80), save, dimension(500) :: labels,values
            character(len=80), dimension(200) :: slabel,svalue
            common /atest3/mode,jnlsw,jnlr,jnlw,ibatch
            common /atest4/jcmd,cmdtyp,list
            common /atest6/nproc,myid,mpisw,mpiint,mpiflt
cy
c
        if(ifirst==-1) then
            call mpiutl(1_iknd)
            mode=0
            do i=1,100
                ip(i)=0
                rp(i)=0.0e0_rknd
                sp(i)=' '
            enddo
            call gtfile(file,len)
            call mkcmd(file,len,name,nlen,nptr,labels,values,
     +          ncmd,ctable,st,sty,iptr,ip,rp,sp)
c*************************
cc      call prtfl(file,len)
cc      call prtfl0(file,len)
c**********************
            ip(42)=mode
            ip(48)=mpisw
            ip(49)=nproc
            ip(50)=myid+1
            ifirst=1
            return
        endif
        sp(12)=' '
        if(ifirst==1) then
            jcmd=ncmd
            sp(12)(1:6)='quit  '
            mode=ip(42)
            jnlsw=mode
            if(mode>1.or.mode<-1) then
                sp(11)='menu: bad value for mode'
                return
            endif
            if(myid/=0) then
                if(mode==1) then
                    call mkjnl(sp,kflag)
                    if(kflag/=0) go to 40
                    call stfile(filnam,sp(10))
                    call ascutl(jnlr,filnam,'r',kflag)
                    if(kflag/=0) go to 40
                    jnlsw=2
                    mode=-2
                else
                    mode=-2
                    jnlsw=mode
                endif
            else if(mode==0) then
                call xwinit(ncmd,ctable,sp(13))
                call grinit(ip(43))
                do i=1,ncmd
                    if(ctable(i)(10:15)=='mpicmd')  then
                        mpibtn=i
                        call xmpi(mpisw,mpibtn)
                    endif
                enddo
            else if(mode==1) then
                call mkjnl(sp,kflag)
                if(kflag/=0) go to 40
                call stfile(filnam,sp(10))
                call ascutl(jnlr,filnam,'r',kflag)
                if(kflag/=0) go to 40
            endif
            call stfile(filnam,sp(8))
            call ascutl(jnlw,filnam,'w',kflag)
            if(kflag/=0) go to 40
            call stfile(filnam,sp(9))
            call ascutl(ibatch,filnam,'w',kflag)
            if(kflag/=0) go to 40
c
            ulist=' '
            list=' '
            iustat=0
            ifirst=0
        endif
c
        ierr=0
    5   if(ierr>0) sp(11)='command error'
        if(sp(11)/=' ') call filutl(sp(11),0_iknd)
        if(iustat==1.and.ulist==list) iustat=0
        if(iustat==0) then
            if(jnlsw==0) then
                call xgtcmd(list)
            else if(jnlsw/=-2) then
                call getcmd(list)
            endif
        endif
c
c       mpi communication
c
        if(mode==-2.and.jnlsw==-2) then
            call star0(list)
            call parcmd(ncmd,ctable,list,length,nequal,
     +          jcmd,cmdtyp,ierr)
        else
            call parcmd(ncmd,ctable,list,length,nequal,
     +          jcmd,cmdtyp,ierr)
            call star0(list)
        endif
c
        iustat=0
        sp(11)=' '
        if(ierr/=0) go to 5
        if(length==0) then
            if(mode==-1) call discmd(ncmd,ctable)
            ierr=0
            go to 5
        endif
c
c       quit and mpicmd are always executed by all processors
c
        if(mode==-2.and.jnlsw>=1.and.mpisw==-1) then
            if(cmdtyp/='mpicmd'.and.cmdtyp/='quit  ') then
                ii=ichar(list(1:1))
                if(ii>=lowera.and.ii<=lowerz) list(1:1)=char(ii-32)
                if(length<=1) go to 5
            endif
        endif
        if(list(1:1)==ctable(jcmd)(8:8)) go to 30
c
c       reset parameters with display
c
        iustat=1
        ulist=list
        if(nequal==0.and.st(jcmd)>0.and.length>1) then
            call shrtfm(ip,rp,sp,length,sty,st,ierr)
        else
            num=iptr(jcmd+1)-iptr(jcmd)
            call mktabl(jcmd,name,iptr,sname,
     +          nptr,labels,values,sptr,slabel,svalue)
            call reset(num,sname,sptr,slabel,svalue,ip,rp,sp)
            ierr=0
        endif
        if(ctable(jcmd)(1:6)=='mpicmd') ip(48)=mpisw
        sp(11)=' '
        go to 5
c
   30   sp(12)(1:6)=ctable(jcmd)(1:6)
        if(length==1) go to 40
c
c       short form of command
c
        if(nequal==0.and.st(jcmd)>0) then
            call shrtfm(ip,rp,sp,length,sty,st,ierr)
c
c       long form of command
c
        else
            num=iptr(jcmd+1)-iptr(jcmd)
            call mktabl(jcmd,name,iptr,sname,
     +          nptr,labels,values,sptr,slabel,svalue)
            call lookup(sname,num,ip,rp,sp,list,ierr,length)
        endif
c
        if(ierr/=0) go to 5
c
c       quit command
c
   40   if(sp(12)(1:6)=='quit  '.or.cmdtyp=='quit  ') then
            call mpiutl(-1_iknd)
            jcmd=-1
            if(mode==0) call xwinit(jcmd,ctable,sp(13))
            if(jnlsw>=1) call ascutl(jnlr,filnam,'c',kflag)
            call ascutl(jnlw,filnam,'c',kflag)
            call ascutl(ibatch,filnam,'c',kflag)
c
c       journal command
c
        else if(cmdtyp=='journl') then
            ierr=0
            if(jnlsw<=0) then
                call mkjnl(sp,kflag)
                if(kflag/=0) go to 5
                call stfile(filnam,sp(10))
                call ascutl(jnlr,filnam,'r',kflag)
                if(kflag/=0) then
                    sp(11)='journl: cannot open file'
                else
                    sp(11)='journl: ok'
                    jnlsw=1
                endif
                go to 5
            else
                go to 5
            endif
c
c       user command
c
        else if(cmdtyp=='usrcmd') then
            iustat=1
            ulist=list
            sp(11)='usrcmd: ok'
c
c       mpi command
c
        else if(cmdtyp=='mpicmd') then
            if(length==1) then
                mpisw=-mpisw
                ip(48)=mpisw
            else
                if(ip(48)/=1) ip(48)=-1
                mpisw=ip(48)
            endif
            if(mpisw==1) then
                sp(11)='mpi is on'
            else
                sp(11)='mpi is off'
            endif
            ierr=0
            if(mode==0) call xmpi(mpisw,mpibtn)
            go to 5
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine parcmd(ncmd,ctable,list,length,nequal,
     +      jcmd,cmdtyp,ierr)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(24) :: lequal,lcomma
            character(len=1) :: lcmd,ucmd
            character(len=6) :: cmdtyp
            character(len=15), dimension(*) :: ctable
            character(len=80) :: list
cy
        call fxcase(list,length,ncomma,nequal,ndbleq,
     +      lcomma,lequal,icomnt)
c
c       obvious errors
c
        call filutl(list,1_iknd)
        if(length==0) then
            ierr=0
            return
        endif
        ierr=1
        jcmd=0
        cmdtyp=' '
        if(icomnt==1) then
            ierr=-1
            return
        endif
        if(nequal>0) then
            if(ncomma/=nequal-1) return
        else
            if(ncomma>0) return
        endif
        if((ndbleq/2)*2/=ndbleq) return
c
c       find command code
c
        do icmd=1,ncmd
            lcmd=ctable(icmd)(8:8)
            ii=ichar(lcmd)-32
            ucmd=char(ii)
            if(lcmd==list(1:1).or.ucmd==list(1:1)) go to 20
        enddo
        return
   20   if(lcmd==list(1:1)) cmdtyp=ctable(icmd)(10:15)
        jcmd=icmd
        ierr=0
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine shrtfm(ip,rp,sp,length,sty,st,ierr)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: st,ip
            real(kind=rknd), dimension(*) :: rp
            character(len=1), dimension(*) :: sty
            character(len=6) :: cmdtyp
            character(len=80), dimension(100) :: sp
            character(len=80) :: list
            common /atest4/jcmd,cmdtyp,list
cy
c       short form of command
c
        ierr=0
        ll=length-1
        if(sty(jcmd)=='i') then
            call cint(list(2:2),ll,ival,ierr)
            if(ierr==0) ip(st(jcmd))=ival
        else if(sty(jcmd)=='r') then
            call creal(list(2:2),ll,rval,ierr)
            if(ierr==0) rp(st(jcmd))=rval
        else if(sty(jcmd)=='l') then
            sp(st(jcmd))=' '
            sp(st(jcmd))(1:ll-2)=list(3:length-1)
        else
            sp(st(jcmd))=' '
            sp(st(jcmd))(1:ll)=list(2:length)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine prtfl(file,len)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(24) :: lcomma,lequal
            character(len=80), dimension(*) :: file
            character(len=80) :: lstr,line
            character(len=10), save :: mark='+123456789'
            character(len=1), save, dimension(4) :: cc
cy
            data cc/'n','c','r','s'/
c
c       get rid of comments, blank lines and spaces
c
        ishift=0
        do i=1,len
            lstr=file(i)
            call fxcase(lstr,length,ncomma,nequal,ndbleq,
     +          lcomma,lequal,icomnt)
            if(icomnt==1.or.length==0) then
                ishift=ishift+1
            else
                file(i-ishift)=' '
                file(i-ishift)(1:length)=lstr(1:length)
            endif
        enddo
        len=len-ishift
c
c
c
        ii=1
        k=1
        is=8
        do m=1,4
            do i=1,len
                if(file(i)(1:1)/=cc(m)) cycle
                call fstr(lstr,length,file(i),0_iknd)
                line=' '
                line(6:6)=mark(ii:ii)
                line(is+1:is+1)=char(39)
                ll=is+1+length
                line(is+2:ll)=lstr(1:length)
                line(ll+1:ll+1)=char(39)
                if(ii/=10.and.k<len) then
                    line(ll+2:ll+2)=','
                else
                    line(ll+2:ll+2)='/'
                endif
                if(ii==1) then
                    k9=min(k+9,len)
                    write(unit=10,fmt='(12x,a17,i3,a1,i3,a2)')
     +              'data (file0(i),i=',k,',',k9,')/'
                endif
                write(unit=10,fmt='(a80)') line
                k=k+1
                ii=ii+1
                if(ii>10) ii=1
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine prtfl0(file,len)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(24) :: lcomma,lequal
            character(len=80), dimension(*) :: file
            character(len=80) :: lstr
            character(len=1), save, dimension(4) :: cc
cy
            data cc/'n','c','r','s'/
c
c       get rid of comments, blank lines and spaces
c
        ishift=0
        do i=1,len
            lstr=file(i)
            call fxcase(lstr,length,ncomma,nequal,ndbleq,
     +          lcomma,lequal,icomnt)
            if(icomnt==1.or.length==0) then
                ishift=ishift+1
            else
                file(i-ishift)=' '
                file(i-ishift)(1:length)=lstr(1:length)
            endif
        enddo
        len=len-ishift
c
c
        do m=1,4
            do i=1,len
                if(file(i)(1:1)/=cc(m)) cycle
                call fstr(lstr,length,file(i),0_iknd)
                write(unit=11,fmt='(a80)') lstr
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine getnam(name,nlen)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(24) :: lcomma,lequal
            integer(kind=iknd), dimension(2) :: ig
            real(kind=rknd), dimension(2) :: rg
            character(len=15), dimension(*) :: name
            character(len=15), save, dimension(20) :: name0
            character(len=80) :: lstr
            character(len=80), dimension(500) :: file
            character(len=80), dimension(5) :: sg
cy
            data (name0(i),i= 1, 5)/
     +      '  1 index  i  s','  2 vname  n  s','  3 alias  a  s',
     1      '  4 vtype  t  s','  5 deflt  d  l'/
c
c
        call gtfile(file,len)
        nlen=0
        do i=1,len
            lstr=file(i)
            call fxcase(lstr,length,ncomma,nequal,ndbleq,
     +          lcomma,lequal,icomnt)
            if(icomnt==1.or.length==0) cycle
            if(lstr(1:1)/='n') cycle
c
            nlen=nlen+1
            name(nlen)=' '
            do j=1,5
                sg(j)=' '
            enddo
            call lookup(name0,5_iknd,ig,rg,sg,lstr,ierr,length)
            name(nlen)(1:3)=sg(1)(1:3)
            name(nlen)(5:10)=sg(2)(1:6)
            name(nlen)(12:13)=sg(3)(1:2)
            name(nlen)(15:15)=sg(4)(1:1)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mkcmd(file,len,name,nlen,nptr,labels,values,
     +      ncmd,ctable,st,sty,iptr,ip,rp,sp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: iptr,st,nptr
            integer(kind=iknd), dimension(24) :: lcomma,lequal,inum,snum
            integer(kind=iknd), dimension(300) :: num
            integer(kind=iknd), dimension(2) :: ig
            integer(kind=iknd), dimension(500) :: jv
            integer(kind=iknd), dimension(200) :: iv,ic
            integer(kind=iknd), dimension(100) :: ip
            integer(kind=iknd), save :: mxnam=300,mxcmd=24,
     +          mxvar=500,mxlst=500
            real(kind=rknd), dimension(2) :: rg
            real(kind=rknd), dimension(100) :: rp
            character(len=1) :: typ,jtyp,uppera,upperz,cc
            character(len=1), dimension(*) :: sty
            character(len=15), dimension(*) :: name,ctable
            character(len=15), save, dimension(20) :: name0
            character(len=15) :: ntemp
            character(len=80) :: lstr
            character(len=80), dimension(*) :: labels,values,file
            character(len=80), dimension(5) :: sg
            character(len=80), dimension(100) :: sp
            character(len=80), dimension(500) :: l0,v0
cy
            data (name0(i),i= 1, 14)/
     +      '  1 index  i  s','  2 vname  n  s','  3 alias  a  s',
     1      '  4 vtype  t  s','  5 deflt  d  l','  1 cname  c  s',
     2      '  2 cmdkey k  s','  3 ctype  t  s','  1 cname  c  s',
     3      '  2 vname  n  s','  3 short  s  s','  1 vname  n  s',
     4      '  2 value  v  s','  3 label  l  l'/
c
c       get rid of comments, blank lines and spaces
c
        ishift=0
        uppera=char(65)
        upperz=char(90)
        do i=1,len
            lstr=file(i)
            call fxcase(lstr,length,ncomma,nequal,ndbleq,
     +          lcomma,lequal,icomnt)
            if(icomnt==1.or.length==0) then
                ishift=ishift+1
            else
                cc=lstr(1:1)
                if(cc>=uppera.and.cc<=upperz) then
                    ii=ichar(cc)+32
                    lstr(1:1)=char(ii)
                endif
                file(i-ishift)=' '
                file(i-ishift)(1:length)=lstr(1:length)
            endif
        enddo
        len=len-ishift
c
c       name and ctable
c
        ncmd=0
        ilen=0
        nlen=0
        do i=1,len
c
c       name
c
            if(file(i)(1:1)=='n') then
                nlen=nlen+1
                if(nlen>mxnam) stop 3001
                name(nlen)=' '
                do j=1,5
                    sg(j)=' '
                enddo
                call lookup(name0(1),5_iknd,ig,rg,sg,file(i),
     +              ierr,length)
                name(nlen)(1:3)=sg(1)(1:3)
                name(nlen)(5:10)=sg(2)(1:6)
                name(nlen)(12:13)=sg(3)(1:2)
                typ=sg(4)(1:1)
                name(nlen)(15:15)=typ
                if(typ=='i'.or.typ=='r'.or.typ=='s') ilen=ilen+1
                if(sg(5)/=' ') then
                    call cint(sg(1),3_iknd,indx,ierr)
                    call fstr(lstr,length,sg(5),0_iknd)
                    if(typ=='i') then
                        call cint(lstr,length,ip(indx),ierr)
                    else if(typ=='r') then
                        call creal(lstr,length,rp(indx),ierr)
                    else
                        sp(indx)=' '
                        sp(indx)(1:length)=lstr(1:length)
                    endif
                endif
c
c       command
c
            else if(file(i)(1:1)=='c') then
                ncmd=ncmd+1
                if(ncmd>mxcmd) stop 3002
                ctable(ncmd)=' '
                do j=1,3
                    sg(j)=' '
                enddo
                call lookup(name0(6),3_iknd,ig,rg,sg,file(i),
     +              ierr,length)
                ctable(ncmd)(1:6)=sg(1)(1:6)
                ctable(ncmd)(8:8)=sg(2)(1:1)
                ctable(ncmd)(10:15)=sg(3)(1:6)
            endif
        enddo
c
c       sort
c
        nn=ilen+1
        do 5 i=1,ilen
            typ=name(i)(15:15)
            if(typ=='i'.or.typ=='r'.or.typ=='s') cycle
            do j=nn,nlen
                jtyp=name(j)(15:15)
                if(jtyp=='i'.or.jtyp=='r'.or.jtyp=='s') then
                    ntemp=name(i)
                    name(i)=name(j)
                    name(j)=ntemp
                    nn=j+1
                    go to 5
                endif
            enddo
            stop 9413
    5   continue
c
c       iptr, nptr
c
        do i=1,nlen
            num(i)=0
        enddo
        do i=1,ncmd
            inum(i)=0
            snum(i)=0
        enddo
c
        ilen=0
        jlen=0
        do i=1,len
c
c       reset variable
c
            if(file(i)(1:1)=='r') then
                ilen=ilen+1
                if(ilen>mxvar) stop 3003
                do j=1,3
                    sg(j)=' '
                enddo
                call lookup(name0(9),3_iknd,ig,rg,sg,file(i),
     +              ierr,length)
                do j=1,ncmd
                    if(sg(1)(1:6)==ctable(j)(1:6)) go to 10
                enddo
                stop 1001
   10           ic(ilen)=j
                do j=1,nlen
                    if(sg(2)(1:6)==name(j)(5:10)) go to 20
                enddo
cc              write(6,*) file(i)
                stop 1002
   20           iv(ilen)=j
                if(sg(3)(1:1)=='1') iv(ilen)=-j
                typ=name(j)(15:15)
                if(typ=='i'.or.typ=='r'.or.typ=='s') then
                    inum(ic(ilen))=inum(ic(ilen))+1
                else
                    snum(ic(ilen))=snum(ic(ilen))+1
                endif
c
c       switch
c
            else if(file(i)(1:1)=='s') then
                jlen=jlen+1
                if(jlen>mxlst) stop 3004
                do j=1,3
                    sg(j)=' '
                enddo
                call lookup(name0(12),3_iknd,ig,rg,sg,file(i),
     +              ierr,length)
                do j=1,nlen
                    if(sg(1)(1:6)==name(j)(5:10)) go to 30
                enddo
                stop 1003
   30           jv(jlen)=j
                v0(jlen)=sg(2)
                l0(jlen)=sg(3)
                num(j)=num(j)+1
            endif
        enddo
c
c       compute start of iptr
c
        iptr(1)=ncmd+2
        do i=1,ncmd
            iptr(i+1)=iptr(i)+inum(i)+snum(i)
            snum(i)=iptr(i)+inum(i)
            inum(i)=iptr(i)
            st(i)=0
        enddo
c
c       compute the rest of iptr
c
        do i=1,ilen
            icmd=ic(i)
            ivar=abs(iv(i))
            typ=name(ivar)(15:15)
            if(typ=='i'.or.typ=='r'.or.typ=='s') then
                k=inum(icmd)
                inum(icmd)=k+1
            else
                k=snum(icmd)
                snum(icmd)=k+1
            endif
            iptr(k)=ivar
            if(iv(i)<0) then
                call cint(name(ivar),3_iknd,indx,jerr)
                st(icmd)=indx
                sty(icmd)=typ
            endif
        enddo
c
c       compute nptr
c
        nptr(1)=1
        do i=1,nlen
            nptr(i+1)=nptr(i)+num(i)
            num(i)=nptr(i)
        enddo
c
c       compute labels and values
c
        do i=1,jlen
            ivar=jv(i)
            k=num(ivar)
            num(ivar)=k+1
            labels(k)=l0(i)
            values(k)=v0(i)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine usrset(file,len,ip,rp,sp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(5) :: iptr,st
            integer(kind=iknd), dimension(301) :: nptr
            integer(kind=iknd), dimension(100) :: ip
            real(kind=rknd), dimension(100) :: rp
            character(len=1), dimension(5) :: sty
            character(len=15), dimension(300) :: name
            character(len=15), dimension(5) :: ctable
            character(len=80), dimension(500) :: labels,values
            character(len=80), dimension(*) :: file
            character(len=80), dimension(100) :: sp
cy
c       mkcmd interface for usrcmd
c
        if(len>500) return
        call mkcmd(file,len,name,nlen,nptr,labels,values,
     +      ncmd,ctable,st,sty,iptr,ip,rp,sp)
        call reset(nlen,name,nptr,labels,values,ip,rp,sp)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine gtfile(file,len)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            character(len=80), save, dimension(500) :: file0
            character(len=80), dimension(*) :: file
cy
            data (file0(i),i=  1, 10)/
     +  'ni=1,n=ntf,t=i',
     1  'ni=2,n=nvf,t=i',
     2  'ni=3,n=nbf,t=i',
     3  'ni=4,n=ndf,t=i',
     4  'ni=5,n=ifirst,t=i,a=f,d="1"',
     5  'ni=6,n=iprob,t=i,a=p,d="1"',
     6  'ni=7,n=itask,t=i,a=t,d="0"',
     7  'ni=8,n=ispd,t=i,a=i,d="0"',
     8  'ni=9,n=method,t=i,a=mt,d="1"',
     9  'ni=10,n=mxcg,t=i,a=c,d="10"'/
            data (file0(i),i= 11, 20)/
     +  'ni=11,n=mxnwtt,t=i,a=n,d="10"',
     1  'ni=12,n=ising,t=i,d="0"',
     2  'ni=13,n=nrl,t=i,d="1"',
     3  '#ni=15,n=mxstep,t=i,a=ms,d="20"',
     4  'ni=17,n=irtype,t=i,a=i,d="0"',
     5  'ni=18,n=mxord,t=i,a=i,d="9"',
     6  'ni=19,n=ierrsw,t=i,a=e,d="0"',
     7  'ni=20,n=iadapt,t=i,a=a,d="1"',
     8  'ni=21,n=irefn,t=i,a=ir,d="2"',
     9  'ni=22,n=ndtrgt,t=i,a=n,d="100000"'/
            data (file0(i),i= 21, 30)/
     +  'ni=24,n=mflag,t=i,a=m,d="0"',
     1  'ni=25,n=iflag,t=i',
     2  'ni=27,n=newntf,t=i',
     3  'ni=28,n=newnvf,t=i',
     4  'ni=29,n=newnbf,t=i',
     5  'ni=30,n=newndf,t=i',
     6  'ni=31,n=nvv,t=i',
     7  'ni=32,n=nbb,t=i',
     8  'ni=33,n=ndd,t=i',
     9  'ni=34,n=nvi,t=i'/
            data (file0(i),i= 31, 40)/
     +  'ni=35,n=nbi,t=i',
     1  'ni=36,n=ndi,t=i',
     2  'ni=37,n=ntg,t=i',
     3  'ni=38,n=nvg,t=i',
     4  'ni=39,n=nbg,t=i',
     5  'ni=40,n=ndg,t=i',
     6  'ni=41,n=iusrsw,t=i,d="1"',
     7  'ni=42,n=mode,t=i,d="0"',
     8  'ni=43,n=ngraph,t=i,d="0"',
     9  'ni=44,n=fdevce,t=i,a=d,d="0"'/
            data (file0(i),i= 41, 50)/
     +  'ni=45,n=gdevce,t=i,a=d,d="1"',
     1  'ni=46,n=jdevce,t=i,a=d,d="2"',
     2  'ni=47,n=mpirgn,t=i,a=mr,d="0"',
     3  'ni=48,n=mpisw,t=i,a=i,d="-1"',
     4  'ni=49,n=nproc,t=i,d="1"',
     5  'ni=50,n=irgn,t=i,d="1"',
     6  'ni=51,n=mxcolr,t=i,a=mc,d="256"',
     7  'ni=52,n=ifun,t=i,a=f,d="0"',
     8  'ni=53,n=inplsw,t=i,a=i,d="0"',
     9  'ni=54,n=igrsw,t=i,a=i,d="0"'/
            data (file0(i),i= 51, 60)/
     +  'ni=56,n=ncon,t=i,a=c,d="11"',
     1  'ni=57,n=icont,t=i,a=ic,d="0"',
     2  'ni=58,n=iscale,t=i,a=s,d="0"',
     3  'ni=59,n=lines,t=i,a=l,d="0"',
     4  'ni=60,n=numbrs,t=i,a=n,d="0"',
     5  'ni=61,n=nx,t=i,a=nx,d="0"',
     6  'ni=62,n=ny,t=i,a=ny,d="0"',
     7  'ni=63,n=nz,t=i,a=nz,d="1"',
     8  'ni=64,n=mx,t=i,a=mx,d="1"',
     9  'ni=65,n=my,t=i,a=my,d="-1"'/
            data (file0(i),i= 61, 70)/
     +  'ni=66,n=mz,t=i,a=mz,d="1"',
     1  'ni=68,n=icrsn,t=i,a=cr,d="0"',
     2  'ni=69,n=itrgt,t=i,a=it,d="10000"',
     3  'ni=71,n=nvdd,t=i',
     4  'ni=72,n=lipath,t=i',
     5  'ni=76,n=nef,t=i',
     6  'ni=77,n=ngf,t=i',
     7  'ni=78,n=ndl,t=i',
     8  'ni=79,n=ievals,t=i',
     9  'ni=80,n=itnum,t=i'/
            data (file0(i),i= 71, 80)/
     +  'ni=82,n=maxpth,t=i',
     1  'ni=83,n=maxt,t=i',
     2  'ni=84,n=maxv,t=i',
     3  'ni=85,n=maxd,t=i',
     4  'ni=86,n=maxb,t=i',
     5  'ni=90,n=ndf,t=i',
     6  'ni=91,n=nb,t=i',
     7  'ni=92,n=lenja,t=i',
     8  'ni=93,n=lenad,t=i',
     9  'ni=94,n=lenaod,t=i'/
            data (file0(i),i= 81, 90)/
     +  'ni=95,n=lenju,t=i',
     1  'ni=96,n=lenuod,t=i',
     2  'ni=97,n=lenju0,t=i',
     3  'ni=98,n=lenu0,t=i',
     4  'ni=99,n=lenja0,t=i,d="0"',
     5  'ni=100,n=lenjuc,t=i,d="0"',
     6  'ni=1,n=rltrgt,t=r,a=l,d="0.0e0"',
     7  'ni=2,n=rtrgt,t=r,a=r,d="0.0e0"',
     8  'ni=3,n=rmtrgt,t=r,a=m,d="0.1e0"',
     9  'ni=4,n=dtol,t=r,a=d,d="1.0e-3"'/
            data (file0(i),i= 91,100)/
     +  'ni=6,n=smin,t=r,a=sn,d="0.0e0"',
     1  'ni=7,n=smax,t=r,a=sx,d="0.0e0"',
     2  'ni=8,n=rmag,t=r,a=m,d="1.0e0"',
     3  'ni=9,n=cenx,t=r,a=cx,d="0.5e0"',
     4  'ni=10,n=ceny,t=r,a=cy,d="0.5e0"',
     5  'ni=12,n=hmax,t=r,a=hx,d="0.1e0"',
     6  'ni=13,n=grade,t=r,a=g,d="1.5e0"',
     7  'ni=14,n=hmin,t=r,a=hn,d="0.001e0"',
     8  'ni=16,n=xmin,t=r',
     9  'ni=17,n=ymin,t=r'/
            data (file0(i),i=101,110)/
     +  'ni=18,n=xmax,t=r',
     1  'ni=19,n=ymax,t=r',
     2  'ni=21,n=rl,t=r',
     3  'ni=22,n=r,t=r',
     4  'ni=23,n=rldot,t=r',
     5  'ni=24,n=rdot,t=r',
     6  'ni=25,n=sval,t=r',
     7  'ni=26,n=rlstrt,t=r',
     8  'ni=27,n=rstrt,t=r',
     9  '#ni=28,n=tstart,t=r,a=s,d="0.0e0"'/
            data (file0(i),i=111,120)/
     +  '#ni=29,n=tend,t=r,a=e,d="0.0e0"',
     1  '#ni=30,n=tmtol,t=r,a=tt,d="1.0e-2"',
     2  'ni=31,n=rl0,t=r',
     3  'ni=32,n=r0,t=r',
     4  'ni=33,n=rl0dot,t=r',
     5  'ni=34,n=r0dot,t=r',
     6  'ni=35,n=sval0,t=r',
     7  'ni=37,n=enorm1,t=r',
     8  'ni=38,n=unorm1,t=r',
     9  'ni=39,n=enorm2,t=r'/
            data (file0(i),i=121,130)/
     +  'ni=40,n=unorm2,t=r',
     1  'ni=41,n=n0,t=r',
     2  'ni=42,n=e0,t=r',
     3  'ni=43,n=nf,t=r',
     4  'ni=44,n=ef,t=r',
     5  '#ni=45,n=sh,t=r,d="0.0e0"',
     6  '#ni=46,n=tcur,t=r',
     7  '#ni=47,n=deltat,t=r',
     8  '#ni=48,n=dtmin,t=r',
     9  '#ni=49,n=dtmax,t=r'/
            data (file0(i),i=131,140)/
     +  '#ni=50,n=utnorm,t=r',
     1  'ni=52,n=step,t=r,d="1.0e0"',
     2  'ni=53,n=reler0,t=r,d="1.0e0"',
     3  'ni=54,n=relerr,t=r,d="1.0e0"',
     4  'ni=55,n=anorm,t=r,d="1.0e0"',
     5  'ni=56,n=relres,t=r,d="1.0e0"',
     6  'ni=57,n=bratio,t=r,d="1.0e0"',
     7  'ni=58,n=dnew,t=r',
     8  'ni=59,n=bnorm0,t=r',
     9  'ni=60,n=bmnrm0,t=r'/
            data (file0(i),i=141,150)/
     +  'ni=63,n=rmu,t=r,d="1.0e0"',
     1  'ni=64,n=reg4,t=r,d="1.0e0"',
     2  'ni=65,n=reg5,t=r,d="0.0e0"',
     3  'ni=67,n=scleqn,t=r',
     4  'ni=68,n=scale,t=r',
     5  'ni=69,n=thetal,t=r',
     6  'ni=70,n=thetar,t=r',
     7  'ni=71,n=sigma,t=r',
     8  'ni=72,n=delta,t=r',
     9  'ni=73,n=drdrl,t=r'/
            data (file0(i),i=151,160)/
     +  'ni=74,n=seqdot,t=r',
     1  'ni=76,n=qual,t=r',
     2  'ni=77,n=angmn,t=r,d="0.25e0"',
     3  'ni=78,n=diam,t=r',
     4  'ni=79,n=best,t=r',
     5  'ni=80,n=area,t=r',
     6  'ni=82,n=sfave,t=r',
     7  'ni=83,n=sfvar,t=r',
     8  'ni=84,n=sfmin,t=r',
     9  'ni=85,n=sfmax,t=r'/
            data (file0(i),i=161,170)/
     +  'ni=86,n=relerp,t=r',
     1  'ni=87,n=eave2,t=r',
     2  'ni=88,n=eaveg,t=r',
     3  'ni=91,n=rl1,t=r',
     4  'ni=92,n=rl2,t=r',
     5  'ni=93,n=rl3,t=r',
     6  'ni=94,n=rl4,t=r',
     7  'ni=95,n=rl5,t=r',
     8  'ni=96,n=rl6,t=r',
     9  'ni=97,n=rl7,t=r'/
            data (file0(i),i=171,180)/
     +  'ni=98,n=rl8,t=r',
     1  'ni=99,n=rl9,t=r',
     2  'ni=100,n=rl10,t=r',
     3  'ni=1,n=ftitle,t=l,a=t,d="triplt"',
     4  'ni=2,n=ititle,t=l,a=t,d="inplt"',
     5  'ni=3,n=gtitle,t=l,a=t,d="gphplt"',
     6  'ni=5,n=shcmd,t=l,a=c',
     7  'ni=6,n=rwfile,t=f,a=f,d="pltmg_mpixxx.rw"',
     8  'ni=7,n=jrfile,t=f,a=f,d="pltmg.jnl"',
     9  'ni=8,n=jwfile,t=f,d="journl_mpixxx.jnl"'/
            data (file0(i),i=181,190)/
     +  'ni=9,n=bfile,t=f,d="output_mpixxx.out"',
     1  'ni=10,n=jtfile,t=f,d="jnltmp_mpixxx.jnl"',
     2  'ni=11,n=iomsg,t=l',
     3  'ni=12,n=cmd,t=s',
     4  'ni=13,n=logo,t=l,d="pltmg 12.0"',
     5  'ni=14,n=bgclr,t=l,d="gray85"',
     6  'ni=15,n=btnbg,t=l,d="gray30"',
     7  'ni=17,n=hffile,t=f,d="figxxx.hf"',
     8  'ni=18,n=psfile,t=f,d="figxxx.ps"',
     9  'ni=19,n=xpfile,t=f,d="figxxx.xpm"'/
            data (file0(i),i=191,200)/
     +  'ni=20,n=bhfile,t=f,d="figxxx.bh"',
     1  'ni=21,n=sghost,t=f,d="localhost"',
     2  'cc=pltmg,k=s,t=popup',
     3  'cc=trigen,k=t,t=popup',
     4  'cc=triplt,k=f,t=popup',
     5  'cc=gphplt,k=g,t=popup',
     6  'cc=inplt,k=i,t=popup',
     7  'cc=read,k=r,t=file',
     8  'cc=write,k=w,t=file',
     9  'cc=usrcmd,k=u,t=usrcmd'/
            data (file0(i),i=201,210)/
     +  'cc=journl,k=j,t=journl',
     1  'cc=shell,k=k,t=popup',
     2  'cc=mpi,k=p,t=mpicmd',
     3  'cc=quit,k=q,t=quit',
     4  'rc=pltmg,n=iprob',
     5  'rc=pltmg,n=ifirst',
     6  'rc=pltmg,n=itask',
     7  'rc=pltmg,n=ispd',
     8  'rc=pltmg,n=mxcg',
     9  'rc=pltmg,n=mxnwtt'/
            data (file0(i),i=211,220)/
     +  'rc=pltmg,n=rltrgt',
     1  'rc=pltmg,n=rtrgt',
     2  'rc=pltmg,n=dtol',
     3  'rc=pltmg,n=method',
     4  'rc=pltmg,n=rmtrgt',
     5  '#rc=pltmg,n=mxstep',
     6  '#rc=pltmg,n=tmtol',
     7  '#rc=pltmg,n=tstart',
     8  '#rc=pltmg,n=tend',
     9  'rc=trigen,n=iadapt'/
            data (file0(i),i=221,230)/
     +  'rc=trigen,n=ifirst',
     1  'rc=trigen,n=ndtrgt',
     2  'rc=trigen,n=mxord',
     3  'rc=trigen,n=irtype',
     4  'rc=trigen,n=ierrsw',
     5  'rc=trigen,n=irefn',
     6  'rc=trigen,n=hmax',
     7  'rc=trigen,n=hmin',
     8  'rc=trigen,n=grade',
     9  'rc=triplt,n=ifun,s=1'/
            data (file0(i),i=231,240)/
     +  'rc=triplt,n=iscale',
     1  'rc=triplt,n=lines',
     2  'rc=triplt,n=numbrs',
     3  'rc=triplt,n=fdevce',
     4  'rc=triplt,n=nx',
     5  'rc=triplt,n=ny',
     6  'rc=triplt,n=nz',
     7  'rc=triplt,n=ncon',
     8  'rc=triplt,n=icont',
     9  'rc=triplt,n=icrsn'/
            data (file0(i),i=241,250)/
     +  'rc=triplt,n=itrgt',
     1  'rc=triplt,n=mxcolr',
     2  'rc=triplt,n=smin',
     3  'rc=triplt,n=smax',
     4  'rc=triplt,n=rmag',
     5  'rc=triplt,n=cenx',
     6  'rc=triplt,n=ceny',
     7  'rc=triplt,n=mpirgn',
     8  'rc=triplt,n=ftitle',
     9  'rc=gphplt,n=igrsw,s=1'/
            data (file0(i),i=251,260)/
     +  'rc=gphplt,n=mx',
     1  'rc=gphplt,n=my',
     2  'rc=gphplt,n=mz',
     3  'rc=gphplt,n=gdevce',
     4  'rc=gphplt,n=mxcolr',
     5  'rc=gphplt,n=mpirgn',
     6  'rc=gphplt,n=gtitle',
     7  'rc=inplt,n=inplsw,s=1',
     8  'rc=inplt,n=iscale',
     9  'rc=inplt,n=lines'/
            data (file0(i),i=261,270)/
     +  'rc=inplt,n=numbrs',
     1  'rc=inplt,n=jdevce',
     2  'rc=inplt,n=rmag',
     3  'rc=inplt,n=cenx',
     4  'rc=inplt,n=ceny',
     5  'rc=inplt,n=ncon',
     6  'rc=inplt,n=mxcolr',
     7  'rc=inplt,n=icrsn',
     8  'rc=inplt,n=itrgt',
     9  'rc=inplt,n=ititle'/
            data (file0(i),i=271,280)/
     +  'rc=inplt,n=smin',
     1  'rc=inplt,n=smax',
     2  'rc=inplt,n=mpirgn',
     3  'rc=read,n=rwfile,s=1',
     4  'rc=write,n=rwfile,s=1',
     5  'rc=journl,n=jrfile,s=1',
     6  'rc=shell,n=shcmd,s=1',
     7  'rc=mpi,n=mpisw,s=1',
     8  'rc=mpi,n=mpirgn',
     9  'rc=mpi,n=mflag'/
            data (file0(i),i=281,290)/
     +  'sn=ifirst,v=0,l="default"',
     1  'sn=ifirst,v=1,l="initialize linear elements"',
     2  'sn=ifirst,v=2,l="initialize quadratic elements"',
     3  'sn=ifirst,v=3,l="initialize cubic elements"',
     4  'sn=ifirst,v=4,l="initialize quartic elements"',
     5  'sn=ifirst,v=5,l="initialize quintic elements"',
     6  'sn=ifirst,v=6,l="initialize degree 6 elements"',
     7  'sn=ifirst,v=7,l="initialize degree 7 elements"',
     8  'sn=ifirst,v=8,l="initialize degree 8 elements"',
     9  'sn=ifirst,v=9,l="initialize degree 9 elements"'/
            data (file0(i),i=291,300)/
     +  'sn=iprob,v=1,l="simple pde"',
     1  'sn=iprob,v=2,l="obstacle problem"',
     2  'sn=iprob,v=3,l="continuation problem"',
     3  'sn=iprob,v=4,l="parameter identification"',
     4  'sn=iprob,v=5,l="optimal control"',
     5  '#sn=iprob,v=6,l="parabolic problem"',
     6  'sn=iprob,v=-1,l="dd solve - simple pde (mpi) "',
     7  'sn=iprob,v=-2,l="dd solve - obstacle  (mpi)"',
     8  'sn=iprob,v=-3,l="dd solve - continuation (mpi)"',
     9  'sn=iprob,v=-4,l="dd solve - parameter identification (mpi)"'/
            data (file0(i),i=301,310)/
     +  'sn=iprob,v=-5,l="dd solve - optimal control (mpi)"',
     1  'sn=ispd,v=0,l="nonsymmetric"',
     2  'sn=ispd,v=1,l="symmetric"',
     3  'sn=itask,v=0,l="target point / default"',
     4  'sn=itask,v=1,l="compute singular point"',
     5  'sn=itask,v=2,l="switch branches"',
     6  'sn=itask,v=3,l="initialize, lambda fixed"',
     7  'sn=itask,v=4,l="initialize, rho fixed"',
     8  'sn=itask,v=5,l="sigma = 0, lambda fixed"',
     9  'sn=itask,v=6,l="sigma = 0, rho fixed"'/
            data (file0(i),i=311,320)/
     +  'sn=itask,v=7,l="sigma = 0, theta = 1"',
     1  'sn=itask,v=8,l="shape optimization"',
     2  'sn=itask,v=9,l="use functional"',
     3  '#sn=itask,v=10,l="time steps"',
     4  '#sn=itask,v=11,l="fixed time"',
     5  'sn=method,v=0,l="hb"',
     6  'sn=method,v=1,l="ilu"',
     7  'sn=irtype,v=1,l="h-adaptive only"',
     8  'sn=irtype,v=-1,l="p-adaptive only"',
     9  'sn=irtype,v=0,l="hp-adaptive"'/
            data (file0(i),i=321,330)/
     +  'sn=ierrsw,v=0,l="global continuous recovery"',
     1  'sn=ierrsw,v=1,l="patchwise continuous recovery"',
     2  'sn=iadapt,v=0,l="error estimates"',
     3  'sn=iadapt,v=1,l="refine or unrefine"',
     4  'sn=iadapt,v=-1,l="refine or unrefine (qxy)"',
     5  'sn=iadapt,v=2,l="unrefine and refine"',
     6  'sn=iadapt,v=-2,l="unrefine and refine (qxy)"',
     7  'sn=iadapt,v=3,l="mesh smoothing"',
     8  'sn=iadapt,v=-3,l="mesh smoothing (qxy)"',
     9  'sn=iadapt,v=4,l="uniform mesh refinement"'/
            data (file0(i),i=331,340)/
     +  'sn=iadapt,v=-4,l="uniform degree refinement"',
     1  'sn=iadapt,v=5,l="skeleton --> triangulation"',
     2  'sn=iadapt,v=6,l="load balance (mpi)"',
     3  'sn=iadapt,v=7,l="reconcile mesh (mpi)"',
     4  'sn=fdevce,v=0,l="socket 0"',
     5  'sn=fdevce,v=1,l="socket 1"',
     6  'sn=fdevce,v=2,l="socket 2"',
     7  'sn=fdevce,v=3,l="socket 3"',
     8  'sn=fdevce,v=4,l="bh file"',
     9  'sn=fdevce,v=5,l="ps file"'/
            data (file0(i),i=341,350)/
     +  'sn=fdevce,v=6,l="xpm file"',
     1  'sn=fdevce,v=7,l="popup 0"',
     2  'sn=fdevce,v=8,l="popup 1"',
     3  'sn=fdevce,v=9,l="popup 2"',
     4  'sn=fdevce,v=10,l="popup 3"',
     5  'sn=fdevce,v=11,l="hf file"',
     6  'sn=gdevce,v=0,l="socket 0"',
     7  'sn=gdevce,v=1,l="socket 1"',
     8  'sn=gdevce,v=2,l="socket 2"',
     9  'sn=gdevce,v=3,l="socket 3"'/
            data (file0(i),i=351,360)/
     +  'sn=gdevce,v=4,l="bh file"',
     1  'sn=gdevce,v=5,l="ps file"',
     2  'sn=gdevce,v=6,l="xpm file"',
     3  'sn=gdevce,v=7,l="popup 0"',
     4  'sn=gdevce,v=8,l="popup 1"',
     5  'sn=gdevce,v=9,l="popup 2"',
     6  'sn=gdevce,v=10,l="popup 3"',
     7  'sn=gdevce,v=11,l="hf file"',
     8  'sn=jdevce,v=0,l="socket 0"',
     9  'sn=jdevce,v=1,l="socket 1"'/
            data (file0(i),i=361,370)/
     +  'sn=jdevce,v=2,l="socket 2"',
     1  'sn=jdevce,v=3,l="socket 3"',
     2  'sn=jdevce,v=4,l="bh file"',
     3  'sn=jdevce,v=5,l="ps file"',
     4  'sn=jdevce,v=6,l="xpm file"',
     5  'sn=jdevce,v=7,l="popup 0"',
     6  'sn=jdevce,v=8,l="popup 1"',
     7  'sn=jdevce,v=9,l="popup 2"',
     8  'sn=jdevce,v=10,l="popup 3"',
     9  'sn=jdevce,v=11,l="hf file"'/
            data (file0(i),i=371,380)/
     +  'sn=ifun,v=0,l="u"',
     1  'sn=ifun,v=1,l="|grad u|"',
     2  'sn=ifun,v=2,l="grad u"',
     3  'sn=ifun,v=3,l="qxy"',
     4  'sn=ifun,v=4,l="vector qxy"',
     5  'sn=ifun,v=5,l="error"',
     6  'sn=ifun,v=6,l="udot"',
     7  'sn=ifun,v=7,l="evr"',
     8  'sn=ifun,v=8,l="evl"',
     9  'sn=ifun,v=9,l="um"'/
            data (file0(i),i=381,390)/
     +  'sn=ifun,v=10,l="uc"',
     1  'sn=ifun,v=11,l="dual"',
     2  'sn=ifun,v=12,l="scaling factor"',
     3  'sn=inplsw,v=0,l="region tag"',
     4  'sn=inplsw,v=1,l="load balance"',
     5  'sn=inplsw,v=2,l="element quality"',
     6  'sn=inplsw,v=3,l="max angle"',
     7  'sn=inplsw,v=4,l="min angle"',
     8  'sn=inplsw,v=5,l="mesh grading"',
     9  '#sn=inplsw,v=6,l="refinement"'/
            data (file0(i),i=391,400)/
     +  '#sn=inplsw,v=7,l="unrefinement"',
     1  'sn=inplsw,v=6,l="polynomial degree"',
     2  'sn=inplsw,v=7,l="element diameter"',
     3  'sn=igrsw,v=0,l="newton conv"',
     4  'sn=igrsw,v=1,l="linear eqns conv"',
     5  'sn=igrsw,v=-1,l="matrix stats"',
     6  'sn=igrsw,v=2,l="subroutine times"',
     7  'sn=igrsw,v=-2,l="time pie chart"',
     8  'sn=igrsw,v=3,l="continuation path"',
     9  'sn=igrsw,v=-3,l="load balance"'/
            data (file0(i),i=401,410)/
     +  'sn=igrsw,v=4,l="h1 error"',
     1  'sn=igrsw,v=-4,l="l2 error"',
     2  'sn=igrsw,v=5,l="ip array"',
     3  'sn=igrsw,v=-5,l="sp array"',
     4  'sn=igrsw,v=6,l="rp array"',
     5  'sn=icont,v=0,l="do not smooth function"',
     6  'sn=icont,v=1,l="smooth function"',
     7  'sn=iscale,v=0,l="linear"',
     8  'sn=iscale,v=1,l="log"',
     9  'sn=iscale,v=2,l="arcsinh"'/
            data (file0(i),i=411,420)/
     +  'sn=lines,v=0,l="triangulation"',
     1  'sn=lines,v=1,l="regions"',
     2  'sn=lines,v=2,l="load balance"',
     3  'sn=lines,v=3,l="contours"',
     4  'sn=lines,v=-1,l="graphics triangulation"',
     5  'sn=numbrs,v=0,l="none"',
     6  'sn=numbrs,v=1,l="triangles/regions"',
     7  'sn=numbrs,v=2,l="vertices"',
     8  'sn=numbrs,v=3,l="edges"',
     9  'sn=numbrs,v=4,l="arcs"'/
            data (file0(i),i=421,430)/
     +  'sn=numbrs,v=5,l="bdy cond"',
     1  'sn=numbrs,v=6,l="bdy tag"',
     2  'sn=numbrs,v=7,l="processor"',
     3  'sn=numbrs,v=8,l="vertex type"',
     4  'sn=numbrs,v=9,l="degrees of freedom"',
     5  'sn=numbrs,v=10,l="element degree"',
     6  'sn=icrsn,v=0,l="no coarsening"',
     7  'sn=icrsn,v=1,l="coarsening"',
     8  'sn=mpisw,v=1,l="turn on mpi"',
     9  'sn=mpisw,v=-1,l="turn off mpi"'/
c
        data len0/430/
c
        len=len0
        do i=1,len
            file(i)=file0(i)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mktabl(icmd,name,iptr,sname,
     +      nptr,labels,values,sptr,slabel,svalue)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: iptr,nptr,sptr
            character(len=15), dimension(*) :: name,sname
            character(len=80), dimension(*) :: labels,values,slabel
            character(len=80), dimension(*) :: svalue
cy
c       compute sname, sptr, slabel, svalue
c
        sptr(1)=1
        do i=iptr(icmd),iptr(icmd+1)-1
            k=i+1-iptr(icmd)
            nl=iptr(i)
            sname(k)=name(nl)
            ii=sptr(k)
            do j=nptr(nl),nptr(nl+1)-1
                slabel(ii)=labels(j)
                svalue(ii)=values(j)
                ii=ii+1
            enddo
            sptr(k+1)=ii
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine getcmd(list)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            character(len=80) :: list
            common /atest3/mode,jnlsw,jnlr,jnlw,ibatch
cy
c       get the next command from
c       the tty or the command file
c
c       jnlsw  > 0    get command from journal file
c              = 0    get command from x-windows interface
c              < 0    get command for terminal window
c
c
c       print a prompt symbol
c
        if(jnlsw<0) then
            call crtutl(list,'r','command:')
        else if(jnlsw>0) then
            call ascstr(jnlr,list,80_iknd,kflag)
            if(kflag/=0) then
                call ascutl(jnlr,list,'c',kflag)
                if(mode==1.or.jnlsw==2) then
                    list='q'
                else
                    list=' '
                    jnlsw=mode
                endif
            endif
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine lookup(name,num,ip,rp,sp,list,ierr,length)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(24) :: ival,lequal,lcomma,iptr
            integer(kind=iknd), dimension(*) :: ip
            real(kind=rknd), dimension(*) :: rp
            real(kind=rknd), dimension(24) :: rval
            character(len=80), dimension(*) :: sp
            character(len=80), dimension(24) :: sval
            character(len=15), dimension(*) :: name
            character(len=6) :: lname
            character(len=2) :: sname
            character(len=*) :: list
            character(len=1), save :: dbleq='"'
cy
c       determine number of entries
c
        ierr=0
        call fxcase(list,length,ncomma,nequal,ndbleq,
     +      lcomma,lequal,icomnt)
        if(num<=0.or.length==1) return
        ierr=1
        if(icomnt==1.or.(ndbleq/2)*2/=ndbleq) return
        if(nequal==0.or.ncomma/=nequal-1) return
        if(ncomma>0) then
            do i=1,ncomma
                if(lcomma(i)<lequal(i).or.
     +              lcomma(i)>lequal(i+1)) return
            enddo
        endif
c
c       the main loop
c
        do ii=1,nequal
            lname=' '
            sname=' '
            istart=2
            imid=lequal(ii)
            iend=length
            if(ii>1) istart=lcomma(ii-1)+1
            if(ii<nequal) iend=lcomma(ii)-1
            if(iend<=imid) return
            if(istart>=imid) return
            if(istart+6<imid) return
c
c       search name array for the variable
c
            do i=istart,imid-1
                j=i+1-istart
                if(imid<=istart+2) sname(j:j)=list(i:i)
                lname(j:j)=list(i:i)
            enddo
            do i=1,num
                if(name(i)(12:13)/='  '.and.
     +               name(i)(12:13)==sname) go to 9
                if(name(i)(5:10)==lname) go to 9
            enddo
            return
c
c       compute the value
c
    9       iptr(ii)=i
            ll=iend-imid
            if(name(i)(15:15)=='i') then
                call cint(list(imid+1:imid+1),ll,ival(ii),jerr)
                if(jerr/=0) return
            else if(name(i)(15:15)=='r') then
                call creal(list(imid+1:imid+1),ll,rval(ii),jerr)
                if(jerr/=0) return
            else if(name(i)(15:15)=='s') then
                sval(ii)=' '
                do j=imid+1,iend
                    k=j-imid
                    sval(ii)(k:k)=list(j:j)
                enddo
            else if(name(i)(15:15)=='f') then
                sval(ii)=' '
                do j=imid+1,iend
                    k=j-imid
                    sval(ii)(k:k)=list(j:j)
                enddo
            else
                if(list(iend:iend)/=dbleq) return
                if(list(imid+1:imid+1)/=dbleq) return
                sval(ii)=' '
                do j=imid+2,iend-1
                    k=j-imid-1
                    sval(ii)(k:k)=list(j:j)
                enddo
            endif
        enddo
c
c       update ip and rp arrays
c
        do ii=1,nequal
            i=iptr(ii)
            call cint(name(i),3_iknd,indx,jerr)
            if(name(i)(15:15)=='i') then
                ip(indx)=ival(ii)
            else if(name(i)(15:15)=='r') then
                rp(indx)=rval(ii)
            else
                sp(indx)=sval(ii)
            endif
        enddo
        ierr=0
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine disply(name,num,ip,rp,sp)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: ip
            real(kind=rknd), dimension(*) :: rp
            character(len=15), dimension(*) :: name
            character(len=80), dimension(*) :: sp
            character(len=80), dimension(100) :: sval
            character(len=80) :: stemp
            character(len=100) :: msg
cy
c       print reset paremeters
c
        nn=0
        do i=1,num
            call cint(name(i),3_iknd,indx,jerr)
            if(name(i)(15:15)=='i') then
                sval(i)=' '
                call sint(sval(i),ll,ip(indx))
                nn=nn+1
            else if(name(i)(15:15)=='r') then
                sval(i)=' '
                nn=nn+1
                call sreal(sval(i),ll,rp(indx),3_iknd,0_iknd)
            else
                go to 10
            endif
        enddo
c
   10   do i=1,nn,4
            write(unit=msg,fmt='(4(a9,1x,a10))')
     +          (name(j)(5:13),sval(j)(1:10),
     1           j=i,min(i+3,nn))
            call crtutl(msg,'w','prompt: ')
        enddo
c
        do i=nn+1,num
            call cint(name(i),3_iknd,indx,jerr)
            if(name(i)(15:15)=='s') then
                call fstr(stemp,length,sp(indx),0_iknd)
            else if(name(i)(15:15)=='f') then
                call fstr(stemp,length,sp(indx),0_iknd)
            else
                call fstr(stemp,length,sp(indx),1_iknd)
            endif
            write(unit=msg,fmt='(a9,1x,80a1)')
     +          name(i)(5:13),(stemp(k:k),k=1,length)
            call crtutl(msg,'w','prompt: ')
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine discmd(ncmd,ctable)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            character(len=15), dimension(*) :: ctable
            character(len=100) :: msg
cy
c       print command list
c
        if(ncmd<=6) then
            nstep=ncmd
        else
            nstep=min((ncmd+1)/2,6)
        endif
        do k=1,ncmd,nstep
            write(unit=msg,fmt='(6(a8,4x))')
     +          (ctable(j)(1:8),j=k,min(k+nstep-1,ncmd))
            call crtutl(msg,'w','prompt: ')
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine fxcase(list,length,ncomma,nequal,ndbleq,
     +      lcomma,lequal,icomnt)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: lequal,lcomma
            character(len=*) :: list
            character(len=1), save :: blank=' ',comma=',',
     +          equal='=',dbleq='"',commnt='#'
            character(len=1) :: cc,uppera,upperz
cy
        llist=80
        length=0
        ncomma=0
        nequal=0
        ndbleq=0
        if(list(1:1)==commnt) then
            icomnt=1
            do i=llist,1,-1
                if(list(i:i)/=blank) then
                    length=i
                    return
                endif
            enddo
            return
        else
            icomnt=0
        endif
        uppera=char(65)
        upperz=char(90)
c
c       delete blanks, find equal, commas, and double quotes
c       convert upper to lower case except for command code
c
        do i=1,llist
            cc=list(i:i)
            list(i:i)=blank
            if(ndbleq-(ndbleq/2)*2==0) then
                if(cc/=blank) then
                    length=length+1
                    if(cc==comma) then
                        ncomma=ncomma+1
                        lcomma(ncomma)=length
                    else if(cc==equal) then
                        nequal=nequal+1
                        lequal(nequal)=length
                    else if(cc==dbleq) then
                        ndbleq=ndbleq+1
                    else if(cc>=uppera.and.cc<=upperz) then
                        ii=ichar(cc)+32
                        if(length>1.and.nequal==ncomma)
     +                      cc=char(ii)
                    endif
                    list(length:length)=cc
                endif
            else
                length=length+1
                list(length:length)=cc
                if(cc==dbleq) ndbleq=ndbleq+1
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sreal(list,length,val,ndig,just)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd) :: elen,mlen,just
            character(len=*) :: list
            character(len=1), save :: zero='0',minus='-',
     +          e='e',dot='.'
            character(len=100) :: ex,mant
cy
c       compute character string for floating point number
c
        if(val==0.0e0_rknd) then
            length=3
            list(1:1)=zero
            list(2:2)=dot
            list(3:3)=zero
        else
            zc=abs(val)
            zz=log10(zc)
            iex=int(zz)
            ratio=10.0e0_rknd**(zz-real(iex,rknd))
c**         ratio=zc*(10.0e0_rknd**(-iex))
            if(iex==-1) then
                h=0.5e0_rknd*10.0e0_rknd**(2-ndig)
            else
                h=0.5e0_rknd*10.0e0_rknd**(1-ndig)
            endif
            if(ratio+h<1.0e0_rknd) then
                ratio=ratio*10.0e0_rknd
                iex=iex-1
            else if(ratio+h>=10.0e0_rknd) then
                ratio=ratio/10.0e0_rknd
                iex=iex+1
            endif
c
c       exponent field
c
            call sint(ex,elen,iex)
c
c       mantissa field
c
            if(iex==-1) then
                n=int(ratio*10.0e0_rknd**(ndig-2)+0.5e0_rknd)
            else
                n=int(ratio*10.0e0_rknd**(ndig-1)+0.5e0_rknd)
            endif
c
            if(just/=1) then
   90           k=n/10
                j=n-10*k
                if(j==0) then
                    n=k
                    go to 90
                endif
            endif
            call sint(mant,mlen,n)
            if(val>0) then
                is=0
            else
                is=1
                list(1:1)=minus
            endif
            if(iex==-1) then
                list(is+1:is+1)=zero
                list(is+2:is+2)=dot
                do i=1,mlen
                    list(is+i+2:is+i+2)=mant(i:i)
                enddo
                mlen=mlen+1
                iex=0
            else if(iex==1) then
                list(is+1:is+1)=mant(1:1)
                list(is+2:is+2)=zero
                list(is+3:is+3)=dot
                list(is+4:is+4)=zero
                if(mlen<=2) then
                    if(mlen==2) list(is+2:is+2)=mant(2:2)
                    mlen=3
                else
                    list(is+2:is+2)=mant(2:2)
                    do i=3,mlen
                        list(is+i+1:is+i+1)=mant(i:i)
                    enddo
                endif
                iex=0
            else
                list(is+1:is+1)=mant(1:1)
                list(is+2:is+2)=dot
                if(mlen==1) then
                    list(is+3:is+3)=zero
                    mlen=mlen+1
                else
                    do i=2,mlen
                        list(is+i+1:is+i+1)=mant(i:i)
                    enddo
                endif
            endif
            if(iex/=0) then
                length=elen+mlen+2+is
                list(is+mlen+2:is+mlen+2)=e
                do i=1,elen
                    list(is+mlen+2+i:is+mlen+2+i)=ex(i:i)
                enddo
            else
                length=mlen+1+is
            endif
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sint(list,length,ival)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(100) :: temp
            character(len=*) :: list
            character(len=10), save :: num='0123456789'
            character(len=1), save :: minus='-'
cy
c       compute character string for integer
c
        if(ival==0) then
            length=1
            list(1:1)=num(1:1)
        else
            length=0
            n=abs(ival)
   10       j=n/10
            i=n-j*10
            length=length+1
            temp(length)=i+1
            n=j
            if(n>0) go to 10
            if(ival<0) then
                list(1:1)=minus
                do i=1,length
                    j=temp(length+1-i)
                    list(i+1:i+1)=num(j:j)
                enddo
                length=length+1
            else
                do i=1,length
                    j=temp(length+1-i)
                    list(i:i)=num(j:j)
                enddo
            endif
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine fstr(ss,length,sval,iquote)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save :: mxchar=80
            character(len=1), save :: blank=' ',dbleq='"'
            character(len=80) :: ss,sval
cy
        istart=mxchar+1
        istop=0
        ss=' '
        do i=1,mxchar
            if(sval(i:i)==blank) cycle
            istart=min(istart,i)
            istop=max(istop,i)
        enddo
        if(iquote==1) then
            ss(1:1)=dbleq
            if(istart>istop) then
                length=3
            else
                length=istop-istart+3
                if(length>mxchar) then
                    istop=istop-(length-mxchar)
                    length=mxchar
                endif
                ss(2:length-1)=sval(istart:istop)
            endif
            ss(length:length)=dbleq
        else
            if(istart>istop) then
                length=1
            else
                length=istop-istart+1
                ss(1:length)=sval(istart:istop)
            endif
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mkname(outnam,innam)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save :: num=0
            character(len=80) :: innam,outnam,temp
            common /atest6/nproc,myid,mpisw,mpiint,mpiflt
cy
c       look for key string and insert number
c
        num=num+1
cccc    if(mpisw==1) call exnum(num)
        call fstr(outnam,length,innam,0_iknd)
        do i=6,length
            if(outnam(i-5:i)=='figxxx') then
                outnam(i-2:i)='000'
                call sint(temp,len,num)
                outnam(i+1-len:i)=temp(1:len)
                return
            endif
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine creal(list,length,val,ierr)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd) :: zero
            character(len=*) :: list
            character(len=1), save :: dot='.',lce='e',blank=' ',
     +          plus='+',minus='-',lcd='d'
            character(len=1) :: uce,cc,ucd
            character(len=1), dimension(80) :: temp
cy
c       compute a real number from a-format input
c
        ii=ichar(lce)-32
        uce=char(ii)
        ii=ichar(lcd)-32
        ucd=char(ii)
        val=0.0e0_rknd
        ierr=1
        newlen=0
        idot=length+1
        iee=length+1
        do i=1,length
            cc=list(i:i)
            list(i:i)=blank
            if(cc==blank) cycle
            newlen=newlen+1
            temp(newlen)=cc
            list(newlen:newlen)=cc
            if(temp(newlen)==lce) iee=newlen
            if(temp(newlen)==uce) iee=newlen
            if(temp(newlen)==lcd) iee=newlen
            if(temp(newlen)==ucd) iee=newlen
            if(temp(newlen)==dot) idot=newlen
        enddo
        if(newlen==0) return
c
c       exponent
c
        if(iee<=newlen) then
            if(iee==1.or.iee==newlen) return
            ll=newlen-iee
            call cint(temp(iee+1),ll,ix,jerr)
            if(jerr/=0) return
            newlen=iee-1
        else
            ix=0
        endif
c
c       mantissa
c
        if(idot<=newlen) then
            if(newlen==1) return
            ix=ix+idot-newlen
            newlen=newlen-1
            if(idot<=newlen) then
                do i=idot,newlen
                    temp(i)=temp(i+1)
                enddo
            endif
        endif
c
c       sign
c
        if(temp(1)==minus.or.temp(1)==plus) then
            if(newlen==1) return
            ii=2
        else
            ii=1
        endif
c
        zero=ichar('0')
        value=0.0e0_rknd
        do i=ii,newlen
            kx=ichar(temp(i))-zero
            if(kx<0.or.kx>9) return
            value=10.0e0_rknd*value+real(kx,rknd)
        enddo
        if(temp(1)==minus) then
            val=-value*(10.0e0_rknd**ix)
        else
            val=value*(10.0e0_rknd**ix)
        endif
        ierr=0
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cint(list,length,ival,ierr)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd) :: zero
            character(len=*) :: list
            character(len=1), save :: blank=' ',plus='+',minus='-'
            character(len=1), dimension(80) :: temp
            character(len=1) :: cc
cy
c       compute an integer from a-format input
c
        ierr=1
        ival=0
        newlen=0
        do i=1,length
            cc=list(i:i)
            list(i:i)=blank
            if(cc==blank) cycle
            newlen=newlen+1
            temp(newlen)=cc
            list(newlen:newlen)=cc
        enddo
        if(newlen==0) return
c
c       sign
c
        if(temp(1)==minus.or.temp(1)==plus) then
            if(newlen==1) return
            ii=2
        else
            ii=1
        endif
c
c
        zero=ichar('0')
        do i=ii,newlen
            ix=ichar(temp(i))-zero
            if(ix<0.or.ix>9) return
            ival=10*ival+ix
        enddo
        if(temp(1)==minus) ival=-ival
        ierr=0
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine cpause()
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            character(len=80) :: cc
            common /atest3/mode,jnlsw,jnlr,jnlw,ibatch
cy
c       wait for user to view picture
c
        if(mode==0.and.jnlsw==1) then
            call xpause()
        else if(mode==-1.and.jnlsw==1) then
            call crtutl(cc,'r','pause:  ')
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine crtutl(list,mode,prompt)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save :: icrtr=5,icrtw=6
            character(len=1) :: mode
            character(len=8) :: prompt
            character(len=80) :: list
cy
c       print a prompt symbol
c
        if(mode=='r') then
            write(icrtw,fmt='(/ a8 $)') prompt
            flush(icrtw)
            read(icrtr,fmt='(a80)') list
            flush(icrtr)
        else if(mode=='w') then
            write(icrtw,fmt='(a80)') list
            flush(icrtw)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine filutl(list,isw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            character(len=1), save :: lowerj='j'
            character(len=80) :: list
            character(len=80), save :: blank=' '
            character(len=100) :: msg
            common /atest3/mode,jnlsw,jnlr,jnlw,ibatch
cy
        if(isw==1) then
            if(list(1:1)==lowerj) then
                write(unit=msg,fmt='(a1,a80)') '#',list
            else
                write(unit=msg,fmt='(a80)') list
            endif
            len=1
            do i=2,80
                if(msg(i:i)/=' ') len=i
            enddo
            call ascstr(jnlw,msg,len,iflag)
            write(unit=msg,fmt='(a8,a80)') 'command:',list
c
            call ascstr(ibatch,blank,1_iknd,iflag)
            call ascstr(ibatch,msg,80_iknd,iflag)
c
            if(mode==0) then
                call xtext(blank)
                call xtext(msg)
            endif
c
            if(mode==-1.and.jnlsw==1) then
                call crtutl(blank,'w','prompt: ')
                call crtutl(msg,'w','prompt: ')
            endif
        else
            call ascstr(ibatch,list,80_iknd,iflag)
            if(mode==0) call xtext(list)
            if(mode==-1) call crtutl(list,'w','prompt: ')
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine mkjnl(sp,iflag)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(11) :: jnlr
            integer(kind=iknd), dimension(24) :: lequal,lcomma
            integer(kind=iknd), save :: maxd=10
            character(len=1) :: lowerj,upperj
            character(len=80), dimension(100) :: sp
            character(len=80), dimension(11) :: name
            character(len=80) :: list,filnam
cy
c       make journal file
c
        lowerj=char(106)
        upperj=char(74)
        do i=1,maxd
            name(i)=' '
            jnlr(i)=-1
        enddo
        if(sp(10)==' ') then
            sp(11)='journl: bad filename'
            go to 50
        endif
        call stfile(filnam,sp(10))
        call ascutl(jnlr(maxd+1),filnam,'w',kflag)
        if(kflag/=0) then
            sp(11)='journl: cannot open file'
            go to 50
        endif
        iflag=0
        sp(11)='journl: ok'
        level=1
        name(1)=sp(7)
c
c       open file
c
   10   if(name(level)==' ') then
            sp(11)='journl: bad filename'
            go to 50
        endif
        if(level>=maxd) then
            sp(11)='journl: too many levels'
            go to 50
        endif
        do i=1,level-1
            if(name(level)==name(i)) then
                sp(11)='journl: bad filename'
                go to 50
            endif
        enddo
        call stfile(filnam,name(level))
        call ascutl(jnlr(level),filnam,'r',kflag)
        if(kflag/=0) then
            sp(11)='journl: cannot open file'
            go to 50
        endif
c
c       read next command
c
   20   call ascstr(jnlr(level),list,80_iknd,kflag)
        if(kflag>0) then
            sp(11)='journl: read error'
            go to 50
        endif
        if(kflag==-1) then
c
c       close current file, reduce level
c
            call ascutl(jnlr(level),filnam,'c',jflag)
            if(jflag/=0) then
                sp(11)='journl: cannot close file'
                return
            endif
            jnlr(level)=-1
            level=level-1
            if(level>=1) go to 20
            call ascutl(jnlr(maxd+1),filnam,'c',jflag)
            return
        endif
c
c       process this command
c
        call fxcase(list,length,ncomma,nequal,ndbleq,
     +      lcomma,lequal,icomnt)
        if(length<=0) then
            go to 20
c
c       check for journal commands
c
        else if(list(1:1)==lowerj.or.list(1:1)==upperj) then
            if(ncomma>0.or.ndbleq>0.or.nequal>=2) then
                sp(11)='journl: command error'
                go to 50
            endif
            if(nequal==1) then
                ll=length-lequal(1)
                name(level+1)=' '
                name(level+1)(1:ll)=list(lequal(1)+1:length)
            endif
            if(list(1:1)==lowerj) then
                level=level+1
                go to 10
            else
                go to 20
            endif
        else
c
c       print this command
c
            call ascstr(jnlr(maxd+1),list,length,kflag)
            if(kflag>0) then
                sp(11)='journl: write error'
                go to 50
            endif
            go to 20
        endif
c
c       close all open files
c
   50   do i=1,maxd+1
            if(jnlr(i)==-1) cycle
            call ascutl(jnlr(i),filnam,'c',kflag)
        enddo
        iflag=-7
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine stfile(outnam,innam)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            character(len=80) :: innam,outnam,temp
            common /atest6/nproc,myid,mpisw,mpiint,mpiflt
cy
c       look for key strng and replace with proc number
c
        call fstr(outnam,length,innam,0_iknd)
        do i=6,length
            if(outnam(i-5:i)=='mpixxx') then
                outnam(i-2:i)='000'
                call sint(temp,len,myid+1)
                outnam(i+1-len:i)=temp(1:len)
                return
            endif
        enddo
        return
        end
c*********************** machine dependent routine *********************
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pltutl(ncolor,red,green,blue)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: red,green,blue
            character(len=80) :: fname,fname0,sp
            common /atest1/ip(100),rp(100),sp(100)
            common /atest5/idevce
cy
c       ncolor > 0 -- initialize graphics using ncolor colors
c       ncolor <= 0 -- exit graphics
c
c       socket graphics
c
        if(idevce>=0.and.idevce<=3) then
            isock=idevce
            call fstr(fname,length,sp(21),0_iknd)
            call vutl(ncolor,red,green,blue,isock,fname)
            if(ncolor<0) call cpause()
c
c       bh file
c
        else if(idevce==4) then
            if(ncolor>0) then
                call mkname(fname0,sp(20))
                call stfile(fname,fname0)
            endif
            call vutl(ncolor,red,green,blue,-1_iknd,fname)
c
c       postscript file
c
        else if(idevce==5) then
            if(ncolor>0) then
                call mkname(fname0,sp(18))
                call stfile(fname,fname0)
            endif
            call psutl(ncolor,red,green,blue,fname)
c
c       xpm file
c
        else if(idevce==6) then
            if(ncolor>0) then
                call mkname(fname0,sp(19))
                call stfile(fname,fname0)
            endif
            call xpmutl(ncolor,red,green,blue,fname)
c
c       classic x graphics
c
        else if(idevce>=7.and.idevce<=10) then
            isock=idevce-7
            call xutl(ncolor,red,green,blue,isock)
            if(ncolor<0) call cpause()
c
c       hf file
c
        else if(idevce==11) then
            call hfutl(ncolor,red,green,blue,sp(17))
        endif
        return
        end
c*********************** machine dependent routine *********************
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pframe(iframe)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            common /atest5/idevce
cy
c       frame/list equivalence table
c        ___ ___ ___       ___ ___ ___
c       |       |   |     |           |
c       |       | 2 |     |           |
c       |   4   |___|     |     1     |
c       |       |   |     |           |
c       |       | 3 |     |           |
c       |___ ___|___|     |___ ___ ___|
c
c        list    frame        type
c
c          1       1          non-rotating, non-lighted
c
c          2       2          non-rotating, non-lighted
c
c          3       3          non-rotating, non-lighted
c
c          4       4          non-rotating, non-lighted
c          5       4              rotating, non-lighted
c          6       4              rotating, non-lighted
c          7       4              rotating,     lighted
c          8       4              rotating,     lighted
c          9       4          non-rotating,     lighted
c
c
        if(idevce>=0.and.idevce<=4) then
            call vframe(iframe)
        else if(idevce==5) then
            call sframe(iframe)
        else if(idevce>=6.and.idevce<=10) then
            call xframe(iframe)
        else if(idevce==11) then
            call hframe(iframe)
        endif
        return
        end
c*********************** machine dependent routine *********************
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pline(x,y,z,n,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y,z
            common /atest5/idevce
cy
c       subroutine pline moves the pen (or whatever)
c       to the point (x(1),y(1)), and then draws the
c       n-1 line segments (x(i-1),y(i-1)) to (x(i),y(i)),
c       i=2,3,....n.
c
        if(idevce>=0.and.idevce<=4) then
            call vline(x,y,z,n,icolor)
        else if(idevce==5) then
            call pspath(x,y,z,n,icolor,0_iknd)
        else if(idevce>=6.and.idevce<=10) then
            call xline(x,y,z,n,icolor)
        else if(idevce==11) then
            call hline(x,y,z,n,icolor)
        endif
        return
        end
c*********************** machine dependent routine *********************
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pfill(x,y,z,n,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y,z
            common /atest5/idevce
cy
c       subroutine pfill fills the n-sided polygon with
c       vertices (x(i),y(i)) with the indicated color
c
        if(idevce>=0.and.idevce<=4) then
            call vfill(x,y,z,n,icolor)
        else if(idevce==5) then
            call pspath(x,y,z,n,icolor,1_iknd)
        else if(idevce>=6.and.idevce<=10) then
            call xfill(x,y,z,n,icolor)
        else if(idevce==11) then
            call hfill(x,y,z,n,icolor)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine psutl(ncolor,red,green,blue,fname)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save :: length
            real(kind=rknd), dimension(*) :: red,green,blue
            character(len=16), save :: hex='0123456789abcdef'
            character(len=80) :: msg,fname
            character(len=80), save :: sname
            common /ps0/id
            common /ps1/scale,fscale,xshift,yshift
cy
c       postscript graphics implementation for pltutl
c       this version is based on suggestions of klas samuelsson for
c       reducing the size of the postscript files
c
c       postscript limited to 256 colors
c
c       print picture
c
        if(ncolor<=0) then
            msg='showpage'
            call ascstr(id,msg,8_iknd,iflag)
            call ascutl(id,sname,'c',iflag)
            return
        endif
c
c       ipl = 1 (0) is portrait (landscape) mode
c       center in 8.5 x 11 inch paper
c       picture is 8 (10.5) inches wide in portrait (landscape)
c       note there are 72 points per inch
c
        ipl=1
c
c       scale factor is 5.e3 (about 4 digits of resolution)
c
        scale=5.0e3_rknd
        fscale=1.0e0_rknd
        xshift=0.0e0_rknd
        yshift=0.0e0_rknd
c
        call fstr(sname,length,fname,0_iknd)
        call ascutl(id,sname,'w',iflag)
c
c       set main definitions
c
        msg='%!'
        call ascstr(id,msg,2_iknd,iflag)
c
        if(ipl==1) then
c***        msg='%%BoundingBox: 18 204 402 588'
            msg='%%BoundingBox: 18 204 594 588'
            call ascstr(id,msg,29_iknd,iflag)
            msg='[384 0 0 384 18 204] concat'
            call ascstr(id,msg,27_iknd,iflag)
        else
            msg='%%BoundingBox: 54 18 558 774'
            call ascstr(id,msg,28_iknd,iflag)
            msg='[0 504 -504 0 558 18] concat'
            call ascstr(id,msg,28_iknd,iflag)
        endif
c
        si=1.0e0_rknd/scale
        write(unit=msg,fmt='(2(f8.6,1x),a5)') si,si,'scale'
        call ascstr(id,msg,23_iknd,iflag)
c
        msg='1 setlinewidth'
        call ascstr(id,msg,14_iknd,iflag)
        msg='2 setlinejoin'
        call ascstr(id,msg,13_iknd,iflag)
        msg='/s {setrgbcolor newpath moveto} def'
        call ascstr(id,msg,35_iknd,iflag)
        msg='/r {count 2 idiv {rlineto} repeat} def'
        call ascstr(id,msg,38_iknd,iflag)
        msg='/f {s r closepath fill} def'
        call ascstr(id,msg,27_iknd,iflag)
        msg='/g {s r stroke} def'
        call ascstr(id,msg,19_iknd,iflag)
c
c       define colors
c
        do i=1,ncolor
            i1=(i-1)/16
            i0=i-1-i1*16
c
            write(unit=msg,fmt='(a2,a1,a1,a2,3(f4.2,1x),a6)')
     +          '/b',hex(i1+1:i1+1),hex(i0+1:i0+1),' {',
     1           red(i),green(i),blue(i),'g} def'
            call ascstr(id,msg,27_iknd,iflag)
c
            write(unit=msg,fmt='(a2,a1,a1,a2,3(f4.2,1x),a6)')
     +          '/c',hex(i1+1:i1+1),hex(i0+1:i0+1),' {',
     1           red(i),green(i),blue(i),'f} def'
            call ascstr(id,msg,27_iknd,iflag)
c
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine sframe(iframe)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            character(len=80) :: msg
            common /ps0/id
            common /ps1/scale,fscale,xshift,yshift
cy
        write(unit=msg,fmt='(a3,i3)') '%%l',iframe
        call ascstr(id,msg,6_iknd,iflag)
c
        if(iframe==2) then
            fscale=scale/2.0e0_rknd
            xshift=scale
            yshift=scale/2.0e0_rknd
        else if(iframe==3) then
            fscale=scale/2.0e0_rknd
            xshift=scale
            yshift=0.0e0_rknd
        else
            fscale=scale
            xshift=0.0e0_rknd
            yshift=0.0e0_rknd
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine pspath(x,y,z,n,icolor,itype)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y,z
            character(len=100) :: list
            character(len=16), save :: hex='0123456789abcdef'
            common /ps0/id
            common /ps1/scale,fscale,xshift,yshift
cy
c       print a path in compact integer form
c
c       look for first nontrivial entry
c
c***    if(scale/=fscale) return
        length=0
        npts=0
        do i=n-1,1,-1
            ix=nint((x(i+1)-x(i))*fscale)
            iy=nint((y(i+1)-y(i))*fscale)
            if(ix==0.and.iy==0) cycle
            npts=npts+1
            call sint(list(length+1:length+1),lenx,ix)
            length=length+lenx+1
            list(length:length)=' '
            call sint(list(length+1:length+1),leny,iy)
            length=length+leny+1
            list(length:length)=' '
c
            if(length<=60) cycle
            call ascstr(id,list,length-1_iknd,iflag)
            length=0
        enddo
c
c       first point
c
        if(npts==0) return
        ix=nint(x(1)*fscale+xshift)
        iy=nint(y(1)*fscale+yshift)
        call sint(list(length+1:length+1),lenx,ix)
        length=length+lenx+1
        list(length:length)=' '
        call sint(list(length+1:length+1),leny,iy)
        length=length+leny+1
        list(length:length)=' '
c
c       set color, and line/fill
c
        if(itype==1) then
            list(length+1:length+1)='c'
        else
            list(length+1:length+1)='b'
        endif
        i1=(icolor-1)/16
        i0=icolor-1-i1*16
        list(length+2:length+2)=hex(i1+1:i1+1)
        list(length+3:length+3)=hex(i0+1:i0+1)
        length=length+3
        call ascstr(id,list,length,iflag)
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine xutl(ncolor,red,green,blue,id)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=isngl) image
            integer(kind=iknd), save :: nx,ny
            real(kind=rknd), dimension(*) :: red,green,blue
            common /xpm0/iscale,jscale,ishift,image(540000)
            common /xpm1/scale,fscale,xshift,yshift
            common /atest3/mode,jnlsw,jnlr,jnlw,ibatch
cy
c       xwindows graphics implementation for pltutl
c
        if(mode/=0) return
        if(ncolor<=0) then
            call xgdisp(nx,ny,ishift,image)
            return
        endif
c
c       initialize bitmap
c
        do i=1,ncolor
           image(3*i-2)=int(red(i)*65535.0e0_rknd)
           image(3*i-1)=int(green(i)*65535.0e0_rknd)
           image(3*i)=int(blue(i)*65535.0e0_rknd)
        enddo
        call xginit(ncolor,image,id,ix,iy)
        ny=min(600,iy)
        nx=ny*3/2
        scale=real(ny,rknd)
        iscale=nx
        jscale=ny
        ishift=4096
        do k=1,nx*ny
            image(k)=0
        enddo
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine xpmutl(ncolor,red,green,blue,fname)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save :: length,nc,nx,ny,lenc,id=0
            integer(kind=isngl) image
            real(kind=rknd), dimension(*) :: red,green,blue
            character(len=1), save, dimension(92) :: cdef
            character(len=2), save, dimension(4096) :: cmap
            character(len=2) :: cs
            character(len=80) :: fname
            character(len=80), save :: sname
            character(len=4000) :: msg
            common /xpm0/iscale,jscale,ishift,image(540000)
            common /xpm1/scale,fscale,xshift,yshift
cy
            data (cdef(i),i=1,92)/
     +          ' ','.','X','o','O','+','@','#','$','%',
     1          '&','*','=','-',';',':','>',',','<','1',
     2          '2','3','4','5','6','7','8','9','0','q',
     3          'w','e','r','t','y','u','i','p','a','s',
     4          'd','f','g','h','j','k','l','z','x','c',
     5          'v','b','n','m','M','N','B','V','C','Z',
     6          'A','S','D','F','G','H','J','K','L','P',
     7          'I','U','Y','T','R','E','W','Q','!','~',
     8          '^','/','(',')','_','`','|',']','[','{',
     9          '}','|'/
c
c       xpm graphics implementation for pltutl
c
c       xpm limited to 4096 colors
c
        if(ncolor<=0) go to 10
c
        ny=600
c***    ny=260
        nx=ny*3/2
c***    nx=ny
        scale=real(ny,rknd)
        iscale=nx
        jscale=ny
        ishift=4096
        nc=1
        lenc=91
        if(ncolor>lenc) nc=2
c
c       initialize bitmap
c
        do k=1,nx*ny
            image(k)=0
        enddo
c
        call fstr(sname,length,fname,0_iknd)
        call ascutl(id,sname,'w',iflag)
c
c       set main definitions
c
        msg='/* XPM */'
        call ascstr(id,msg,9_iknd,iflag)
        msg(1:14)='static char * '
        if(sname(length-3:length)=='.xpm') then
            msg(15:10+length)=sname(1:length-4)
            ll=10+length
        else
            msg(15:14+length)=sname(1:length)
            ll=14+length
        endif
        msg(ll+1:ll+10)='_xpm[] = {'
        call ascstr(id,msg,ll+10_iknd,iflag)
c
        write(unit=msg,fmt='(a1,i4,1x,i4,1x,i4,1x,i1,a2)')
     +      '"',nx,ny,ncolor,nc,'",'
        call ascstr(id,msg,19_iknd,iflag)
c
c       define colors
c
        do i=1,ncolor
            msg='"       c #ffffffffffff",'
            i2=(i-1)/lenc
            i1=i-1-lenc*i2
            cs(1:1)=cdef(i1+1)
            cs(2:2)=cdef(i2+1)
            msg(2:3)=cs
            cmap(i)=cs
            call hexclr(red(i),green(i),blue(i),msg(12:23))
            call ascstr(id,msg,25_iknd,iflag)
        enddo
        return
c
c       print bitmap
c
   10   do j=ny,1,-1
            msg(1:1)='"'
            if(nc==1) then
                do i=1,nx
                    idx=i+(j-1)*iscale
                    ic=image(idx)-(image(idx)/ishift)*ishift+1
                    msg(i+1:i+2)=cmap(ic)
                enddo
            else
                do i=1,nx
                    idx=i+(j-1)*iscale
                    ic=image(idx)-(image(idx)/ishift)*ishift+1
                    msg(2*i:2*i+1)=cmap(ic)
                enddo
            endif
            if(j/=1) then
                msg(nc*nx+2:nc*nx+3)='",'
                call ascstr(id,msg,nc*nx+3_iknd,iflag)
            else
                msg(nc*nx+2:nc*nx+2)='"'
                call ascstr(id,msg,nc*nx+2_iknd,iflag)
            endif
        enddo
        msg(1:2)='};'
        call ascstr(id,msg,2_iknd,iflag)
        call ascutl(id,sname,'c',iflag)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine hexclr(r,g,b,color)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(3) :: ic
            character(len=12) :: color
            character(len=16), save :: hex='0123456789abcdef'
cy
c       translate (r,g,b) colors to hexidecimal
c
        ic(1)=int(r*65535.0e0_rknd)
        ic(2)=int(g*65535.0e0_rknd)
        ic(3)=int(b*65535.0e0_rknd)
        do i=1,3
            jj=max(0,ic(i))
            jj=min(65535,jj)
            do j=1,4
                kk=jj/16
                ii=jj-kk*16
                color(4*i+1-j:4*i+1-j)=hex(ii+1:ii+1)
                jj=kk
            enddo
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine xframe(iframe)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            common /xpm1/scale,fscale,xshift,yshift
cy
c
        if(iframe==2) then
            fscale=scale/2.0e0_rknd
            xshift=scale
            yshift=scale/2.0e0_rknd
        else if(iframe==3) then
            fscale=scale/2.0e0_rknd
            xshift=scale
            yshift=0.0e0_rknd
        else
            fscale=scale
            xshift=0.0e0_rknd
            yshift=0.0e0_rknd
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine xline(x,y,z,n,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y,z
            common /xpm1/scale,fscale,xshift,yshift
cy
c       pline for xpm graphics
c
c***    if(scale/=fscale) return
        zshift=fscale*0.01e0_rknd
        ix=int(x(1)*fscale+xshift+0.5e0_rknd)
        iy=int(y(1)*fscale+yshift+0.5e0_rknd)
        iz=int(z(1)*fscale+zshift+0.5e0_rknd)
        do i=2,n
            jx=ix
            jy=iy
            jz=iz
            ix=int(x(i)*fscale+xshift+0.5e0_rknd)
            iy=int(y(i)*fscale+yshift+0.5e0_rknd)
            iz=int(z(i)*fscale+zshift+0.5e0_rknd)
            call iline(ix,iy,iz,jx,jy,jz,icolor)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine iline(nix,niy,niz,njx,njy,njz,ic)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=isngl) image
            common /xpm0/iscale,jscale,ishift,image(540000)
cy
c       update bitmap for a line segment
c
        ix=max(nix,1)
        ix=min(ix,iscale)
        jx=max(njx,1)
        jx=min(jx,iscale)
        iy=max(niy,1)
        iy=min(iy,jscale)
        jy=max(njy,1)
        jy=min(jy,jscale)
        iz=niz
        jz=njz
c
        if(ix/=jx) then
            kmin=min(ix,jx)
            kmax=max(ix,jx)
            do k=kmin,kmax
                x=real((k-ix)*jx+(jx-k)*ix,rknd)/real(jx-ix,rknd)
                y=real((k-ix)*jy+(jx-k)*iy,rknd)/real(jx-ix,rknd)
                z=real((k-ix)*jz+(jx-k)*iz,rknd)/real(jx-ix,rknd)
                kx=max(int(x+0.5e0_rknd),1_iknd)
                kx=min(kx,iscale)
                ky=max(int(y+0.5e0_rknd),1_iknd)
                ky=min(ky,jscale)
                kz=int(z+0.5e0_rknd)
                idx=kx+(ky-1)*iscale
                if(kz>=image(idx)/ishift) image(idx)=kz*ishift+ic-1
            enddo
        endif
        if(iy/=jy) then
            kmin=min(iy,jy)
            kmax=max(iy,jy)
            do k=kmin,kmax
                x=real((k-iy)*jx+(jy-k)*ix,rknd)/real(jy-iy,rknd)
                y=real((k-iy)*jy+(jy-k)*iy,rknd)/real(jy-iy,rknd)
                z=real((k-iy)*jz+(jy-k)*iz,rknd)/real(jy-iy,rknd)
                kx=max(int(x+0.5e0_rknd),1_iknd)
                kx=min(kx,iscale)
                ky=max(int(y+0.5e0_rknd),1_iknd)
                ky=min(ky,jscale)
                kz=int(z+0.5e0_rknd)
                idx=kx+(ky-1)*iscale
                if(kz>=image(idx)/ishift) image(idx)=kz*ishift+ic-1
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine xfill(x,y,z,n,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: x,y,z
            real(kind=rknd), dimension(200) :: rm,rz
            common /xpm1/scale,fscale,xshift,yshift
cy
c       pfill for xpm graphics
c
c***    if(scale/=fscale) return
        ixmin=int(x(1)*fscale+xshift+0.5e0_rknd)
        ixmax=ixmin
        iymin=int(y(1)*fscale+yshift+0.5e0_rknd)
        iymax=iymin
        do i=2,n
            ix=int(x(i)*fscale+xshift+0.5e0_rknd)
            iy=int(y(i)*fscale+yshift+0.5e0_rknd)
            ixmin=min(ixmin,ix)
            ixmax=max(ixmax,ix)
            iymin=min(iymin,iy)
            iymax=max(iymax,iy)
        enddo
        if(ixmax-ixmin<iymax-iymin) then
c
c       scan by row index
c
            do k=ixmin,ixmax
c
c       find intersections
c
                xx=(real(k,rknd)-xshift)/fscale
                np=0
                nm=0
                num=0
                j=n
                do i=1,n
                    if(x(i)>xx.and.x(j)<=xx) then
                        np=np+1
                    else if(x(i)<=xx.and.x(j)>xx) then
                        nm=nm+1
                    else
                        go to 5
                    endif
                    num=num+1
                    rm(num)=((xx-x(j))*y(i)+(x(i)-xx)*y(j))/(x(i)-x(j))
                    rz(num)=((xx-x(j))*z(i)+(x(i)-xx)*z(j))/(x(i)-x(j))
                    do m=num-1,1,-1
                       if(rm(m)<rm(m+1)) go to 5
                       rr=rm(m)
                       rm(m)=rm(m+1)
                       rm(m+1)=rr
                       rr=rz(m)
                       rz(m)=rz(m+1)
                       rz(m+1)=rr
                    enddo
    5               j=i
                enddo
                if(nm/=np) stop 6123
c
c       update bitmap along line k
c
                do j=1,num,2
                    iy=int(rm(j  )*fscale+yshift+0.5e0_rknd)
                    iz=int(rz(j  )*fscale       +0.5e0_rknd)
                    jy=int(rm(j+1)*fscale+yshift+0.5e0_rknd)
                    jz=int(rz(j+1)*fscale       +0.5e0_rknd)
                    call iline(k,iy,iz,k,jy,jz,icolor)
                enddo
            enddo
        else
c
c       scan by column index
c
            do k=iymin,iymax
c
c       find intersections
c
                yy=(real(k,rknd)-yshift)/fscale
                np=0
                nm=0
                num=0
                j=n
                do i=1,n
                    if(y(i)>yy.and.y(j)<=yy) then
                        np=np+1
                    else if(y(i)<=yy.and.y(j)>yy) then
                        nm=nm+1
                    else
                        go to 10
                    endif
                    num=num+1
                    rm(num)=((yy-y(j))*x(i)+(y(i)-yy)*x(j))/(y(i)-y(j))
                    rz(num)=((yy-y(j))*z(i)+(y(i)-yy)*z(j))/(y(i)-y(j))
                    do m=num-1,1,-1
                       if(rm(m)<rm(m+1)) go to 10
                       rr=rm(m)
                       rm(m)=rm(m+1)
                       rm(m+1)=rr
                       rr=rz(m)
                       rz(m)=rz(m+1)
                       rz(m+1)=rr
                    enddo
   10               j=i
                enddo
                if(nm/=np) stop 6124
c
c       update bitmap along line k
c
                do j=1,num,2
                    ix=int(rm(j  )*fscale+xshift+0.5e0_rknd)
                    iz=int(rz(j  )*fscale       +0.5e0_rknd)
                    jx=int(rm(j+1)*fscale+xshift+0.5e0_rknd)
                    jz=int(rz(j+1)*fscale       +0.5e0_rknd)
                    call iline(ix,k,iz,jx,k,jz,icolor)
                enddo
            enddo
        endif
c
c       trace boundary
c
        ix=int(x(n)*fscale+xshift+0.5e0_rknd)
        iy=int(y(n)*fscale+yshift+0.5e0_rknd)
        iz=int(z(n)*fscale       +0.5e0_rknd)
        do i=1,n
            jx=ix
            jy=iy
            jz=iz
            ix=int(x(i)*fscale+xshift+0.5e0_rknd)
            iy=int(y(i)*fscale+yshift+0.5e0_rknd)
            iz=int(z(i)*fscale       +0.5e0_rknd)
            call iline(ix,iy,iz,jx,jy,jz,icolor)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine hfutl(ncolor,red,green,blue,fname)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: red,green,blue
            character(len=80) :: fname,fname0,msg
            character(len=80), save  :: sname
            common /hf0/id
cy
        if(ncolor<=0) then
            msg='putl'
            call ascstr(id,msg,4_iknd,iflag)
            call sint(msg,length,ncolor)
            call ascstr(id,msg,length,iflag)
            call ascutl(id,sname,'c',iflag)
            return
        endif
c
        call mkname(fname0,fname)
        call stfile(sname,fname0)
        call ascutl(id,sname,'w',iflag)
        msg='putl'
        call ascstr(id,msg,4_iknd,iflag)
        call sint(msg,length,ncolor)
        call ascstr(id,msg,length,iflag)
        do i=1,ncolor
            write(unit=msg,fmt='(f17.15,1x,f17.15,1x,f17.15)')
     +          red(i),green(i),blue(i)
            call ascstr(id,msg,53_iknd,iflag)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine hframe(iframe)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            character(len=80) :: msg
            common /hf0/id
cy
        msg='list'
        call ascstr(id,msg,4_iknd,iflag)
        call sint(msg,length,iframe)
        call ascstr(id,msg,length,iflag)
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine hline(x,y,z,n,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(n) :: x,y,z
            character(len=80) :: msg
            common /hf0/id
cy
        msg='line'
        call ascstr(id,msg,4_iknd,iflag)
        call sint(msg,length,icolor)
        call ascstr(id,msg,length,iflag)
        call sint(msg,length,n)
        call ascstr(id,msg,length,iflag)
c
        do i=1,n
            write(unit=msg,fmt='(f17.15,1x,f17.15,1x,f17.15)')
     +          x(i),y(i),z(i)
            call ascstr(id,msg,53_iknd,iflag)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine hfill(x,y,z,n,icolor)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(n) :: x,y,z
            character(len=80) :: msg
            common /hf0/id
cy
        msg='fill'
        call ascstr(id,msg,4_iknd,iflag)
        call sint(msg,length,icolor)
        call ascstr(id,msg,length,iflag)
        call sint(msg,length,n)
        call ascstr(id,msg,length,iflag)
        do i=1,n
            write(unit=msg,fmt='(f17.15,1x,f17.15,1x,f17.15)')
     +          x(i),y(i),z(i)
            call ascstr(id,msg,53_iknd,iflag)
        enddo
        return
        end
c*********************** machine dependent routine *********************
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine timer(isw)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save :: len=50
            real(kind=rknd), save :: tx=0.0e0_rknd,ty
            common /pltmg7/time(3,50),hist(22,30)
cy
c       call the clock and return the time in seconds
c       (time differences are used to compute the elapsed time)
c
        ty=tx
        call cpu_time(tx)
c
c       udpate time array (1.0e-10_rknd is below resolution of timer)
c
        if(isw>0) then
            dt=max(tx-ty,1.0e-10_rknd)
            time(1,isw)=time(1,isw)+dt
            time(2,isw)=time(2,isw)+dt
        else if(isw==-1) then
            do i=1,len
                time(1,i)=0.0e0_rknd
            enddo
        else if(isw==-2) then
            do i=1,len
                time(1,i)=0.0e0_rknd
                time(2,i)=0.0e0_rknd
                time(3,i)=0.0e0_rknd
            enddo
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                    edition 12.0 - - - june, 2016
c
c-----------------------------------------------------------------------
        subroutine dpatch(i2,len2,vlist2,blist2,
     +      i3,len3,vlist3,blist3,vtype,vx,vy)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), dimension(*) :: vlist2,blist2,
     +          vlist3,blist3,vtype
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), save, dimension(6) :: red,green,blue
            real(kind=rknd),  dimension(6) :: x,y,z
cy
            common /atest5/idevce
            data   red/1.0e0_rknd,0.0e0_rknd,1.0e0_rknd,
     +          0.0e0_rknd,0.0e0_rknd,1.0e0_rknd/
            data green/1.0e0_rknd,0.0e0_rknd,0.0e0_rknd,
     +          0.0e0_rknd,1.0e0_rknd,1.0e0_rknd/
            data  blue/1.0e0_rknd,0.0e0_rknd,0.0e0_rknd,
     +          1.0e0_rknd,0.0e0_rknd,0.0e0_rknd/
c
        idevce=1
        call pltutl(6_iknd,red,green,blue)
        call pframe(5_iknd)
c
        ax=min(vx(i2),vx(i3))
        bx=ax
        ay=min(vy(i2),vy(i3))
        by=ay
        do i=2,len2+1
            ax=min(ax,vx(vlist2(i)))
            bx=max(bx,vx(vlist2(i)))
            ay=min(ay,vy(vlist2(i)))
            by=max(by,vy(vlist2(i)))
        enddo
        do i=2,len3+1
            ax=min(ax,vx(vlist3(i)))
            bx=max(bx,vx(vlist3(i)))
            ay=min(ay,vy(vlist3(i)))
            by=max(by,vy(vlist3(i)))
        enddo
c
        dx=bx-ax
        dy=by-ay
        dd=max(dx,dy)
        scale=0.9e0_rknd/dd
        xshift=0.5e0_rknd-scale*(ax+bx)/2.0e0_rknd
        yshift=0.5e0_rknd-scale*(ay+by)/2.0e0_rknd
        do i=1,6
            z(i)=0.0e0_rknd
        enddo
        do i=2,len2+1
            x(1)=vx(i2)*scale+xshift
            y(1)=vy(i2)*scale+yshift
            x(2)=vx(vlist2(i))*scale+xshift
            y(2)=vy(vlist2(i))*scale+yshift
            if(vlist2(i)==i3) then
                call pline(x,y,z,2_iknd,3_iknd)
            else if(vtype(i2)>=7.and.i==2) then
                call pline(x,y,z,2_iknd,5_iknd)
            else if(blist2(i)/=0) then
                call pline(x,y,z,2_iknd,5_iknd)
            else
                call pline(x,y,z,2_iknd,2_iknd)
            endif
        enddo
        do i=2,len3+1
            x(1)=vx(i3)*scale+xshift
            y(1)=vy(i3)*scale+yshift
            x(2)=vx(vlist3(i))*scale+xshift
            y(2)=vy(vlist3(i))*scale+yshift
            if(vlist3(i)==i2) then
                call pline(x,y,z,2_iknd,3_iknd)
            else if(vtype(i3)>=7.and.i==2) then
                call pline(x,y,z,2_iknd,5_iknd)
            else if(blist3(i)/=0) then
                call pline(x,y,z,2_iknd,5_iknd)
            else
                call pline(x,y,z,2_iknd,2_iknd)
            endif
        enddo
        is=1
        if(vtype(i2)>=7) is=2
        do i=is,len2
            j1=vlist2(i)
            j2=vlist2(i+1)
            x(1)=vx(j1)*scale+xshift
            y(1)=vy(j1)*scale+yshift
            x(2)=vx(j2)*scale+xshift
            y(2)=vy(j2)*scale+yshift
            if(vtype(j1)>=7.and.vtype(j2)>=7) then
                call pline(x,y,z,2_iknd,5_iknd)
            else
                call pline(x,y,z,2_iknd,2_iknd)
            endif
        enddo
        is=1
        if(vtype(i3)>=7) is=2
        do i=is,len3
            j1=vlist3(i)
            j2=vlist3(i+1)
            x(1)=vx(j1)*scale+xshift
            y(1)=vy(j1)*scale+yshift
            x(2)=vx(j2)*scale+xshift
            y(2)=vy(j2)*scale+yshift
            if(vtype(j1)>=7.and.vtype(j2)>=7) then
                call pline(x,y,z,2_iknd,5_iknd)
            else
                call pline(x,y,z,2_iknd,2_iknd)
            endif
        enddo
c
        call pframe(-5_iknd)
        call pltutl(-1_iknd,red,green,blue)
        return
        end
