c*********************** problem name: ident *************************
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 /val0/k0,ku,kx,ky,kl
common /atest2/iu(100),ru(100),su(100)
cy
call setrl(rl)
a=ru(41)
values(k0)=(a**2+1.0e0_rknd)*ux
values(kx)=a**2+1.0e0_rknd
num=0
do i=1,5
if(iu(i)/=1) cycle
if(i==1) values(kl+num)=ux*a*2.0e0_rknd
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 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 /val0/k0,ku,kx,ky,kl
common /atest2/iu(100),ru(100),su(100)
cy
call setrl(rl)
a=ru(41)
values(k0)=(a**2+1.0e0_rknd)*uy
values(ky)=a**2+1.0e0_rknd
num=0
do i=1,5
if(iu(i)/=1) cycle
if(i==1) values(kl+num)=uy*a*2.0e0_rknd
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 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
character(len=80) :: su
common /val0/k0,ku,kx,ky,kl
common /atest2/iu(100),ru(100),su(100)
cy
call setrl(rl)
c0=ru(42)
c1=ru(43)
c2=ru(44)
values(k0)=c2*u**2+c1*u-c0
values(ku)=c2*u*2.0e0_rknd+c1
num=0
do i=1,5
if(iu(i)/=1) cycle
if(i==2) values(kl+num)=-1.0e0_rknd
if(i==3) values(kl+num)=u
if(i==4) values(kl+num)=u**2
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 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
c
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
call setrl(rl)
d=ru(45)
values(k0)=d
num=0
do i=1,5
if(iu(i)/=1) cycle
if(i==5) values(kl+num)=1.0e0_rknd
values(klb+num)=ru(20+i)
values(kil+num)=ru(10+i)
values(kub+num)=ru(30+i)
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 /val0/k0,ku,kx,ky,kl
common /atest2/iu(100),ru(100),su(100)
cy
uu=1.0e0_rknd
e=exp(-20.0e0_rknd*(x**2+y**2))
values(k0)=e*(u-uu)**2
values(ku)=e*2.0e0_rknd*(u-uu)
gamma=ru(1)
num=0
do i=1,5
if(iu(i)/=1) cycle
num=num+1
values(k0)=values(k0)+gamma*(rl(num)-ru(10+i))**2
values(kl+num-1)=2.0e0*gamma*(rl(num)-ru(10+i))
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
character(len=80) :: su
common /val0/k0,ku,kx,ky,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 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,s,itag,values)
cx
use mthdef
implicit real(kind=rknd) (a-h,o-z)
implicit integer(kind=iknd) (i-n)
real(kind=rknd), dimension(2,*) :: values,rl
character(len=80) :: su
common /val4/j0,js,jl
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 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
num=0
do i=1,5
if(iu(i)/=1) cycle
num=num+1
ru(40+i)=rl(num)
enddo
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
c
c enter input mode
c
num=0
do i=1,5
if(iu(i)==1) then
num=num+1
ru(40+i)=rp(90+num)
endif
enddo
call usrset(iu,ru,su)
nrl=0
do i=1,5
if(iu(i)/=1) iu(i)=0
if(iu(i)==0) cycle
nrl=nrl+1
rp(90+nrl)=ru(40+i)
enddo
ip(13)=nrl
ip(41)=0
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= 1,n=gamma ,a= g,t=r',
1 'n i= 1,n=irl1 ,a=i1,t=i',
2 'n i= 2,n=irl2 ,a=i2,t=i',
3 'n i= 3,n=irl3 ,a=i3,t=i',
4 'n i= 4,n=irl4 ,a=i4,t=i',
5 'n i= 5,n=irl5 ,a=i5,t=i',
6 's n=irl1 ,v= 0,l="a -- static"',
7 's n=irl1 ,v= 1,l="a -- optimize"',
8 's n=irl2 ,v= 0,l="c0 -- static"',
9 's n=irl2 ,v= 1,l="c0 -- optimize"'/
data (file0(i),i= 11,16)/
+ 's n=irl3 ,v= 0,l="c1 -- static"',
1 's n=irl3 ,v= 1,l="c1 -- optimize"',
2 's n=irl4 ,v= 0,l="c2 -- static"',
3 's n=irl4 ,v= 1,l="c2 -- optimize"',
4 's n=irl5 ,v= 0,l="d -- static"',
5 's n=irl5 ,v= 1,l="d -- optimize"'/
c
data len0/16/
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
integer(kind=iknd), save, dimension(13) :: ix,iy
integer(kind=iknd), save :: ntf,nvf,nbf,iprob,ispd
integer(kind=iknd), save :: iadapt,ifirst
real(kind=rknd), dimension(*) :: vx,vy
real(kind=rknd), dimension(2,*) :: sf
real(kind=rknd), dimension(100) :: rp,ru
real(kind=rknd), save :: hmax,grade
real(kind=rknd), save, dimension(5) :: rllb,rlub,rlic
character(len=80), dimension(100) :: sp,su
cy
external sxy
data ix/1,3,3,1,1,-1,-1,-3,-3,-1,-1,1,0/
data iy/-1,-1,1,1,3,3,1,1,-1,-1,-3,-3,0/
data nvf,ntf,nbf/13,4,16/
data iprob,ispd,iadapt,ifirst/4,1,5,1/
data hmax,grade/0.1e0_rknd,1.5e0_rknd/
data rlub/4.0e0_rknd,5.0e0_rknd,5.0e0_rknd,
+ 5.0e0_rknd,0.5e0_rknd/
data rlic/1.0e0_rknd,1.0e0_rknd,1.0e0_rknd,
+ 1.0e0_rknd,-0.5e0_rknd/
data rllb/0.0e0_rknd,-5.0e0_rknd,0.0e0_rknd,
+ 0.0e0_rknd,-1.0e0_rknd/
c
if(ip(41)==1) then
sp(2)='ident'
sp(1)='ident'
sp(3)='ident'
sp(4)='ident'
sp(5)='ident_figxxx.ext'
sp(6)='ident_mpixxx.rw'
sp(7)='ident.jnl'
sp(9)='ident_mpixxx.out'
ip(7)=0
iu(1)=1
iu(2)=1
iu(3)=1
iu(4)=1
iu(5)=1
do i=1,5
ru(10+i)=rlic(i)
ru(20+i)=rllb(i)
ru(30+i)=rlub(i)
ru(40+i)=rlic(i)
enddo
ru(1)=1.0e0_rknd
endif
c
num=0
do i=1,5
if(iu(i)==1) then
num=num+1
rp(90+num)=rlic(i)
endif
enddo
ip(13)=num
ip(6)=4
if(num==0) ip(6)=1
c
c
do i=1,nvf
vx(i)=real(ix(i),rknd)
vy(i)=real(iy(i),rknd)
enddo
do i=1,nbf
ibndry(1,i)=i
ibndry(2,i)=i+1
if(i>=nvf) then
ibndry(1,i)=(i-nvf)*3+1
ibndry(2,i)=nvf
endif
ibndry(3,i)=0
ibndry(4,i)=1
if(i>=nvf) ibndry(4,i)=0
ibndry(5,i)=0
ibndry(6,i)=0
ibndry(7,i)=1
ii=i-(i/3)*3
if(ii==2.and.i<=nvf) then
ibndry(4,i)=2
ibndry(7,i)=i
endif
sf(1,i)=0.0e0_rknd
sf(2,i)=0.0e0_rknd
enddo
ibndry(2,nvf-1)=1
c
ip(1)=ntf
ip(2)=nvf
ip(3)=nbf
ip(5)=max(ip(5),ifirst)
ip(6)=iprob
ip(8)=ispd
ip(20)=iadapt
rp(12)=hmax
rp(13)=grade
c
c make itnode, find symmetries
c
call sklutl(0_iknd,vx,vy,sf,itnode,ibndry,ip,rp,iflag,sxy)
call sklutl(2_iknd,vx,vy,sf,itnode,ibndry,ip,rp,iflag,sxy)
return
end
.