c***********************  problem name: box  ***************************
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine a1xy(x,y,u,ux,uy,rl,itag,values)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values,rl
            character(len=80) :: su
            common /atest2/iu(100),ru(100),su(100)
            common /val0/k0,ku,kx,ky,kl
cy
        values(k0)=ux
        values(kx)=1.0e0_rknd
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine a2xy(x,y,u,ux,uy,rl,itag,values)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values,rl
            character(len=80) :: su
            common /atest2/iu(100),ru(100),su(100)
            common /val0/k0,ku,kx,ky,kl
cy
        values(k0)=uy
        values(ky)=1.0e0_rknd
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine fxy(x,y,u,ux,uy,rl,itag,values)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values,rl
            common /val0/k0,ku,kx,ky,kl
cy
        values(k0)=-1.0e0_rknd
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine gnxy(x,y,u,rl,itag,values)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values,rl
            character(len=80) :: su
            common /val1/k0,ku,kl
            common /atest2/iu(100),ru(100),su(100)
cy
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine gdxy(x,y,rl,itag,values)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values,rl
            character(len=80) :: su
            common /val2/k0,kl,klb,kub,kic,kim,kil
            common /atest2/iu(100),ru(100),su(100)
cy
        num=0
        do i=1,3
            if(iu(i)/=1) cycle
            values(klb+num)=ru(10+i-1)
            values(kub+num)=ru(20+i-1)
            values(kil+num)=ru(30+i-1)
            num=num+1
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine p1xy(x,y,u,ux,uy,rl,itag,values)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values,rl
            character(len=80) :: su
            common /atest2/iu(100),ru(100),su(100)
            common /val0/k0,ku,kx,ky,kl
cy
        delta=ru(7)
        gamma=ru(8)
        values(k0)=gamma*(ux**2+uy**2)/2.0e0_rknd
        values(kx)=ux*gamma
        values(ky)=uy*gamma
        num=0
        do i=1,3
            if(iu(i)/=1) cycle
            num=num+1
            trgt=ru(40+i-1)
            values(k0)=values(k0)+delta*(rl(num)-trgt)**2/2.0e0_rknd
            values(kl+num-1)=delta*(rl(num)-trgt)
        enddo
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine p2xy(x,y,dx,dy,u,ux,uy,rl,itag,jtag,values)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values,rl
            common /val0/k0,ku,kx,ky,kl
cy
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine qxy(x,y,u,ux,uy,rl,itag,values)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: values,rl
            character(len=80) :: su
            common /val3/kf,kf1,kf2,kad
            common /atest2/iu(100),ru(100),su(100)
cy
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine sxy(rl,theta,itag,values)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: rl
            real(kind=rknd), dimension(5), save :: x,y
            real(kind=rknd), dimension(2,*) :: values
            character(len=80) :: su
            data x/-0.5e0_rknd,0.5e0_rknd,0.5e0_rknd,-0.5e0_rknd,
     +          -0.5e0_rknd/
            data y/-0.5e0_rknd,-0.5e0_rknd,0.5e0_rknd,0.5e0_rknd,
     +          -0.5e0_rknd/
            common /val4/j0,js,jl
            common /atest2/iu(100),ru(100),su(100)
cy
        if(itag==0) return
        call setrl(rl)
        scale=ru(1)
        xcen=ru(2)
        ycen=ru(3)
        c=ru(5)
        s=ru(6)
        xt=x(itag+1)-x(itag)
        yt=y(itag+1)-y(itag)
        xx=x(itag)+theta*xt
        yy=y(itag)+theta*yt
        values(1,j0)=xcen+(c*xx-s*yy)*scale
        values(2,j0)=ycen+(s*xx+c*yy)*scale
c
        values(1,js)=(c*xt-s*yt)*scale
        values(2,js)=(s*xt+c*yt)*scale
c
        num=0
        if(iu(1)/=0) then
            values(1,jl+num)=1.0e0_rknd
            values(2,jl+num)=0.0e0_rknd
            num=num+1
        endif
c
        if(iu(2)/=0) then
            values(1,jl+num)=0.0e0_rknd
            values(2,jl+num)=1.0e0_rknd
            num=num+1
        endif
c
        if(iu(3)/=0) then
            values(1,jl+num)=-(s*xx+c*yy)*scale
            values(2,jl+num)=(c*xx-s*yy)*scale
            num=num+1
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine setrl(rl)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            real(kind=rknd), dimension(*) :: rl
            character(len=80) :: su
            common /atest2/iu(100),ru(100),su(100)
cy
c
        num=0
        if(iu(1)/=0) then
            num=num+1
            ru(2)=rl(num)
            ru(30)=rl(num)
        endif
        if(iu(2)/=0) then
            num=num+1
            ru(3)=rl(num)
            ru(31)=rl(num)
        endif
        if(iu(3)/=0) then
            num=num+1
            ru(4)=rl(num)
            ru(5)=cos(rl(num))
            ru(6)=sin(rl(num))
            ru(32)=rl(num)
        endif
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine usrcmd(vx,vy,sf,itnode,ibndry,ip,rp,sp,iu,ru,su)
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,iu
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(100) :: rp,ru
            character(len=80), dimension(100) :: sp,su
cy
        num=0
        do i=1,3
            if(iu(i)==1) then
                num=num+1
                ru(30+i-1)=rp(90+num)
            endif
        enddo
        call usrset(iu,ru,su)
        nrl=0
        do i=1,3
            if(iu(i)/=1) iu(i)=0
            if(iu(i)==0) cycle
            nrl=nrl+1
            rp(90+nrl)=ru(30+i-1)
        enddo
        ip(13)=nrl
        ip(41)=0
c
        return
        end
c-----------------------------------------------------------------------
c
c            piecewise lagrange triangle multi grid package
c
c                  edition 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine usrfil(file,len)
cx
            use mthdef
            implicit real(kind=rknd) (a-h,o-z)
            implicit integer(kind=iknd) (i-n)
            integer(kind=iknd), save :: len0
            character(len=80), save, dimension(100) :: file0
            character(len=80), dimension(*) :: file
cy
            data (file0(i),i=1,10)/
     +  'n i=7,n=delta,a=d,t=r',
     1  'n i=8,n=gamma,a=g,t=r',
     2  'n i= 1,n=irl1  ,a=i1,t=i',
     3  'n i= 2,n=irl2  ,a=i2,t=i',
     4  'n i= 3,n=irl3  ,a=i3,t=i',
     5  's n=irl1  ,v= 0,l="xcen -- static"',
     6  's n=irl1  ,v= 1,l="xcen -- optimize"',
     7  's n=irl2  ,v= 0,l="ycen -- static"',
     8  's n=irl2  ,v= 1,l="ycen -- optimize"',
     9  's n=irl3  ,v= 0,l="angle -- static"'/
            data (file0(i),i=11,11)/
     +  's n=irl3  ,v= 1,l="angle -- optimize"'/
c
            data len0/11/
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 13.0 - - - september, 2018
c
c-----------------------------------------------------------------------
        subroutine gdata(vx,vy,sf,itnode,ibndry,ip,rp,sp,iu,ru,su,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,iu
            real(kind=rknd), dimension(*) :: vx,vy
            real(kind=rknd), dimension(2,*) :: sf
            real(kind=rknd), dimension(100) :: rp,ru
            real(kind=rknd), dimension(4), save :: x,y
            character(len=80), dimension(100) :: sp,su
            data x/-0.5e0_rknd,0.5e0_rknd,0.5e0_rknd,-0.5e0_rknd/
            data y/-0.5e0_rknd,-0.5e0_rknd,0.5e0_rknd,0.5e0_rknd/
cy
            external sxy
c
        if(ip(41)==1) then
            sp(1)='box'
            sp(2)='box'
            sp(3)='box'
            sp(4)='box'
            sp(6)='box_figxxx.ext'
            sp(6)='box_mpixxx.rw'
            sp(7)='box.jnl'
            sp(9)='box_mpixxx.out'
c
            scale=0.1e0_rknd
            ru(1)=scale
c
            pi=3.141592653589793e0_rknd
            angle=pi/8.0e0_rknd
            c=cos(angle)
            s=sin(angle)
            xcen=-0.1e0_rknd
            ycen=-0.1e0_rknd
c
c       gamma, delta
c
            ru(7)=1.0e-2_rknd
            ru(8)=1.0e0_rknd
c
c       min/max/ic/trgt
c
            ru(10)=-0.5e0_rknd+2.0e0_rknd*scale
            ru(11)=-0.5e0_rknd+2.0e0_rknd*scale
            ru(12)=-pi/2.0e0_rknd
c
            ru(20)=0.5e0_rknd-2.0e0_rknd*scale
            ru(21)=0.5e0_rknd-2.0e0_rknd*scale
            ru(22)=pi/2.0e0_rknd
c
            ru(30)=xcen
            ru(31)=ycen
            ru(32)=angle
c
            ru(40)=0.0e0_rknd
            ru(41)=0.0e0_rknd
            ru(42)=0.0e0_rknd
c
            call setrl(ru(30))
c
            iu(1)=1
            iu(2)=1
            iu(3)=1
        endif
        num=0
        do i=1,3
            if(iu(i)==1) then
                num=num+1
                rp(90+num)=ru(30+i-1)
            endif
        enddo
        ip(13)=num
c
        ntf=2
        nvf=8
        nbf=10
        ip(1)=ntf
        ip(2)=nvf
        ip(3)=nbf
        ip(5)=1
        ip(7)=8
        ip(8)=1
c
        ip(20)=5
        ip(22)=100000
        ip(6)=4
c
        do i=1,10
            ibndry(3,i)=0
            ibndry(4,i)=2
            ibndry(5,i)=0
            ibndry(6,i)=0
            ibndry(7,i)=0
        enddo
        do i=1,4
           vx(i)=x(i)
           vy(i)=y(i)
           vx(i+4)=xcen+(c*x(i)-s*y(i))*scale
           vy(i+4)=ycen+(s*x(i)+c*y(i))*scale
c
           sf(1,i+4)=0.0e0_rknd
           sf(2,i+4)=1.0e0_rknd
c
           ibndry(1,i)=i
           ibndry(2,i)=i+1
           ibndry(1,i+4)=i+4
           ibndry(2,i+4)=i+5
           ibndry(3,i+4)=-i
           ibndry(7,i+4)=i
        enddo
        ibndry(2,4)=1
        ibndry(2,8)=5
        i1=5
        i3=5
        s1=(vx(1)-vx(i1))**2+(vy(1)-vy(i1))**2
        s3=(vx(3)-vx(i3))**2+(vy(3)-vy(i3))**2
        do i=6,8
            q1=(vx(1)-vx(i))**2+(vy(1)-vy(i))**2
            if(q1<s1) then
                s1=q1
                i1=i
            endif
            q3=(vx(3)-vx(i))**2+(vy(3)-vy(i))**2
            if(q3<s3) then
                s3=q3
                i3=i
            endif
        enddo
        ibndry(1,9)=1
        ibndry(2,9)=i1
        ibndry(4,9)=0
        ibndry(1,10)=3
        ibndry(2,10)=i3
        ibndry(4,10)=0
c
        rp(12)=0.1e0_rknd
        rp(13)=1.5e0_rknd
        call sklutl(0_iknd,vx,vy,sf,itnode,ibndry,ip,rp,iflag,sxy)
        itnode(5,2)=itnode(5,1)
        return
        end