c************************************************************
c           subroutine file     << msubrtn2.f >>            *
c                                                           * 
c      update ; 01/03/24     /home/g3/inayoshi/VRML/subrtn4 *
c************************************************************
c-------------------------------------
       subroutine triangm1(nx,ny,u,p)
c-------------------------------------
       dimension p(1),u(1)
       ny1=ny-1
c
       call facebe
c
       do 10 j=1,ny1
       call colorp2(nx,j,u)
   10  continue
c
       call coordbe
c
       do 20 j=1,ny1
       call coordp2(nx,j,p)
   20  continue
c
       call coorden5(nx,ny1)
c
       call faceen
c
       return
       end
c-------------------------------------
       subroutine triangm(nx,ny,u,p)
c-------------------------------------
       dimension p(1),u(1)
       ny1=ny-1
c
       do 10 j=1,ny1
       call triangb(nx,j,u,p)
   10  continue  
c
       return
       end
c-------------------------------------
       subroutine triangb(nx,ny,u,p)
c-------------------------------------
       dimension p(1),u(1)
c
       call facebe
       call colorp2(nx,ny,u)
       call coordbe
       call coordp2(nx,ny,p)
       call coorden1(nx)
       call faceen
c
       return
       end
c-------------------------------------------
       subroutine linemesh(p,n1,rd,r,g,b)
c-------------------------------------------
       dimension p(1)
       dimension p1(3*2)
       dimension q(3*12*2)
c
       n11=n1-2
       do 20 i=1,n11
       do 10 j=1,2
c
       i1=3*(i-1)+1+3*(j-1)
       i2=i1+1
       i3=i1+2
c---<< chusin ten set >>
       p1(1+(j-1)*3)=p(i1)
       p1(2+(j-1)*3)=p(i2)
       p1(3+(j-1)*3)=p(i3)
c
       xa=abs(p(i1)-p(i1+3))
       ya=abs(p(i2)-p(i2+3))
       za=abs(p(i3)-p(i3+3))
       amx=amax1(xa,ya,za)  
c
       x=p(i1)
       y=p(i2)
       z=p(i3)
c
       if(amx.eq.xa)  then
               k=1
        else
          if(amx.eq.ya)  then
                 k=2
           else
             if(amx.eq.za)  then
                   k=3
             end if
          end if
       end if
c
c---<< ensyu no point wo motomeru >>
c
       call ensyu(x,y,z,rd,q,j,k)
   10  continue
c
       call linemeshb(12,1,q,rd,r,g,b,k,p1)
   20  continue
c---<< cone >>
       rr=1.57
       if(k.eq.1)   then
            x1=0.0
            y1=0.0
            z1=-1.0
       end if
       if(k.eq.3)   then
            x1=-1.0
            y1=0.0
            z1=0.0
       end if
c
       rd2=rd*2
       h=rd*3
       x=p1(4)
       y=p1(5)
       z=p1(6)
       call cone1(rd2,h,r,g,b,x,y,z,x1,y1,z1,rr)
c
       return
       end
c--------------------------------------------------
       subroutine linemeshb(nx,ny,q,rd,r,g,b,k,p1)
c                 * 1 color *
c--------------------------------------------------
       dimension q(1)
c
       call facebe
c
c----( color )
       write(10,10) r,g,b
   10  format(f9.2,1x,f9.2,1x,f9.2)
c
       call coordbe1(nx)
       call coordp4(nx,ny,q,rd,k,p1)
       call coorden3(nx)
       call faceen
c
       return
       end
c---------------------------------------
       subroutine ensyu(x,y,z,rd,q,j,k)
c---------------------------------------
       dimension q(1)
c
       x1=rd/2*1.73205
       y1=rd/2
       j2=36*(j-1)
c--[ max=xa ]
       if(k.eq.1)    then
c (x)
       do 10 i=1,12
       q(1+(i-1)*3+j2)=x
   10  continue
c (y)
       q(2+j2)=y+rd
       q(5+j2)=y+x1
       q(8+j2)=y+y1
       q(11+j2)=y
       q(14+j2)=y-y1
       q(17+j2)=y-x1
       q(20+j2)=y-rd
       q(23+j2)=y-x1
       q(26+j2)=y-y1
       q(29+j2)=y
       q(32+j2)=y+y1
       q(35+j2)=y+x1
c (z)
       q(3+j2)=z
       q(6+j2)=z+y1
       q(9+j2)=z+x1
       q(12+j2)=z+rd
       q(15+j2)=z+x1
       q(18+j2)=z+y1
       q(21+j2)=z
       q(24+j2)=z-y1
       q(27+j2)=z-x1
       q(30+j2)=z-rd
       q(33+j2)=z-x1
       q(36+j2)=z-y1
       go to 99
       end if
c--[ max=ya ]
       if(k.eq.2)    then
c (x)
       q(1+j2)=x
       q(4+j2)=x+y1
       q(7+j2)=x+x1
       q(10+j2)=x+rd
       q(13+j2)=x+x1
       q(16+j2)=x+y1
       q(19+j2)=x
       q(22+j2)=x-y1
       q(25+j2)=x-x1
       q(28+j2)=x-rd
       q(31+j2)=x-x1
       q(34+j2)=x-y1
c (y)
       do 20 i=1,12
       q(2+(i-1)*3+j2)=y
   20  continue
c (z)
       q(2+j2)=z+rd
       q(5+j2)=z+x1
       q(8+j2)=z+y1
       q(11+j2)=z
       q(14+j2)=z-y1
       q(17+j2)=z-x1
       q(20+j2)=z-rd
       q(23+j2)=z-x1
       q(26+j2)=z-y1
       q(29+j2)=z
       q(32+j2)=z+y1
       q(35+j2)=z+x1
       go to 99
       end if
c--[ max=za ]
       if(k.eq.3)    then
c (x)
       q(1+j2)=x
       q(4+j2)=x+y1
       q(7+j2)=x+x1
       q(10+j2)=x+rd
       q(13+j2)=x+x1
       q(16+j2)=x+y1
       q(19+j2)=x
       q(22+j2)=x-y1
       q(25+j2)=x-x1
       q(28+j2)=x-rd
       q(31+j2)=x-x1
       q(34+j2)=x-y1
c (y)
       q(2+j2)=y+rd
       q(5+j2)=y+x1
       q(8+j2)=y+y1
       q(11+j2)=y
       q(14+j2)=y-y1
       q(17+j2)=y-x1
       q(20+j2)=y-rd
       q(23+j2)=y-x1
       q(26+j2)=y-y1
       q(29+j2)=y
       q(32+j2)=y+y1
       q(35+j2)=y+x1
c (z)
       do 30 i=1,12
       q(3*i+j2)=z
   30  continue
       end if
c
   99  continue
       return
       end
c--------------------------------------------------
       subroutine cylinderm(nx,ny,u,p,rd,br,bg,bb)
c                 * gradation color *
c--------------------------------------------------
       dimension p(1),u(1)
       ny1=ny-1
c
       do 10 j=1,ny1
       call cylinderb(nx,j,u,p,rd,br,bg,bb)
   10  continue
c
       return
       end
c--------------------------------------------------
       subroutine cylinderb(nx,ny,u,p,rd,br,bg,bb)
c                 * gradation color *
c--------------------------------------------------
       dimension p(1),u(1)
c
       call facebe
       call colorp3(nx,ny,u,br,bg,bb)
       call coordbe
       call coordp3(nx,ny,p,rd)
       call coorden2(nx)
       call faceen
c
       return
       end
c--------------------------------------------------
       subroutine cylinderm1(nx,ny,p,rd,r,g,b)
c                 * 1 color *
c--------------------------------------------------
       dimension p(1)
       ny1=ny-1
c
       do 10 j=1,ny1
       call cylinderb1(nx,j,p,rd,r,g,b)
   10  continue
c
       return
       end
c--------------------------------------------------
       subroutine cylinderb1(nx,ny,p,rd,r,g,b)
c                 * 1 color *
c--------------------------------------------------
       dimension p(1)
c
       call facebe
c----( color )
       write(10,10) r,g,b
   10  format(f8.2,1x,f8.2,1x,f8.2)
c
       call coordbe1(nx)
       call coordp3(nx,ny,p,rd)
       call coorden3(nx)
       call faceen
c
       return
       end
c----------------------------------------------------------------------
       subroutine arrow(nx,ny,u,p,rd1,rd2,h,cx,cy,cz,br,bg,bb,cr,cg,cb)
c----------------------------------------------------------------------
       dimension p(1),u(1)
       ny1=ny-1
c
       do 10 j=1,ny1
       call cylinderb(nx,j,u,p,rd1,br,bg,bb)
   10  continue
c
       x1=0.0
       y1=0.0
       z1=1.0
       rr=1.57
c
       call cone1(rd2,h,cr,cg,cb,cx,cy,cz,x1,y1,z1,rr)
       return
       end
c----------------------------------------------------------------------
       subroutine arrow2(nx,ny,u,p,rd1,rd2,h,cx,cy,cz,br,bg,bb,cr,cg,cb)
c----------------------------------------------------------------------
       dimension p(1),u(1)
       ny1=ny-1
c
       do 10 j=1,ny1
       call cylinderb(nx,j,u,p,rd1,br,bg,bb) 
   10  continue
c
       jj=ny1
       i=nx
       j=2
       j1=j+jj-1
       i1=3*(i-1)+1+3*nx*(j1-1)
       i2=i1+1
       i3=i1+2
       cx=p(i1)+0.8*rd2
       cy=p(i2)
       cz=p(i3)+rd1
c
       x1=0.0
       y1=0.0
       z1=-1.0
       rr=1.57
c
       call cone1(rd2,h,cr,cg,cb,cx,cy,cz,x1,y1,z1,rr)
       return
       end
c-----------------------------------------------------
       subroutine cone1(rd,h,r,g,b,x,y,z,x1,y1,z1,rr)
c-----------------------------------------------------
       write(10,20) x,y,z
   20  format("Transform {",/"translation ",f7.2,f7.2,f7.2)
       write(10,21) x1,y1,z1,rr
   21  format("rotation ",f7.2,f7.2,f7.2,f7.2)
       write(10,22)
   22  format("children [")
       write(10,23)
   23  format("Shape {")
       write(10,24)
   24  format("appearance Appearance {")
       write(10,25)
   25  format("material Material {")
       write(10,26) r,g,b
   26  format("diffuseColor",f5.2,f5.2,f5.2)
       write(10,27)
   27  format("}",/"}")
       write(10,28)
   28  format("geometry Cone {")
       write(10,29) rd
   29  format("bottomRadius  ",f5.2)
       write(10,30) h
   30  format("height  ",f5.2)
       write(10,31)
   31  format("}",/"}",/"]",/"}")
c
       return
       end
c------------------------
       subroutine facebe
c------------------------
       write(10,21)
   21  format("Shape {")
       write(10,22)
   22  format("geometry IndexedFaceSet {")
       write(10,23)
   23  format("color Color {")
       write(10,24)
   24  format("color [")
       return
       end
c--------------------------
       subroutine coordbe
c--------------------------
       write(10,21)
   21  format("]")
       write(10,22)
   22  format("}")
       write(10,23)
   23  format("coord Coordinate {")
       write(10,24)
   24  format("point [")
       return
       end
c-------------------------------
       subroutine coordbe1(nx)
c-------------------------------
       write(10,21)
   21  format("]")
       write(10,22)
   22  format("}")
c----( colorindexed )
       nx4=nx*4
       write(10,20)
   20  format("colorIndex [ ")
       write(10,30) (0,i=1,nx4)
   30  format(5000i3)
       write(10,40)
   40  format(" ]")
c
       write(10,23)
   23  format("coord Coordinate {")
       write(10,24)
   24  format("point [")
       return
       end
c--------------------------------------
       subroutine colorp1(nx,ny,u)
c--------------------------------------
       dimension u(1)
c
       do 100 i=1,nx
c
       i1=3*(i-1)+1+3*nx*(ny-1)
       i2=i1+1
       i3=i1+2
       r=u(i1)
       g=u(i2)
       b=u(i3)
c
       r=amax1(r,0.0)
       g=amax1(g,0.0)
       b=amax1(b,0.0)
       r=amin1(r,1.0)
       g=amin1(g,1.0)
       b=amin1(b,1.0)
c
       if(i.eq.nx) then
       write(10,10) r,g,b
   10  format(f6.2,1x,f6.2,1x,f6.2)
       else
       write(10,20) r,g,b
   20  format(f6.2,1x,f6.2,1x,f6.2,",")
       end if
c
  100  continue
       return
       end
c--------------------------------------
       subroutine colorp2(nx,ny,u)
c--------------------------------------
       dimension u(1)
c
       do 100 i=1,nx
       do 100 j=1,2
       j1=j+ny-1
c
       i1=3*(i-1)+1+3*nx*(j1-1)
       i2=i1+1
       i3=i1+2
       r=u(i1)
       g=u(i2)
       b=u(i3)
c
       r=amax1(r,0.0)
       g=amax1(g,0.0)
       b=amax1(b,0.0)
       r=amin1(r,1.0)
       g=amin1(g,1.0)
       b=amin1(b,1.0)
c
       if(i.eq.nx.and.j.eq.2) then
       write(10,10) r,g,b
   10  format(f6.2,1x,f6.2,1x,f6.2)
       else
       write(10,20) r,g,b
   20  format(f6.2,1x,f6.2,1x,f6.2,",")
       end if
c
  100  continue
       return
       end
c--------------------------------------------
       subroutine colorp3(nx,ny,u,br,bg,bb)
c                        * bottom tuki *
c--------------------------------------------
       dimension u(1)
c
       do 100 i=1,nx
       do 100 j=1,2
       j1=j+ny-1
c
       i1=3*(i-1)+1+3*nx*(j1-1)
       i2=i1+1
       i3=i1+2
       r=u(i1)
       g=u(i2)
       b=u(i3)
c
       r=amax1(r,0.0)
       g=amax1(g,0.0)
       b=amax1(b,0.0)
       r=amin1(r,1.0)
       g=amin1(g,1.0)
       b=amin1(b,1.0)
c
       write(10,10) r,g,b
   10  format(f8.2,1x,f8.2,1x,f8.2,",")
c
  100  continue
c----( bottom chusin color )
       write(10,120) br,bg,bb
  120  format(f8.2,1x,f8.2,1x,f8.2)
c
       return
       end
c-------------------------------------
       subroutine coordp1(nx,ny,p)
c-------------------------------------
       dimension p(1)
c
       do 100 i=1,nx
c
       i1=3*(i-1)+1+3*nx*(ny-1)
       i2=i1+1
       i3=i1+2
       x=p(i1)
       y=p(i2)
       z=p(i3)
c
       if(i.eq.nx) then
       write(10,10) x,y,z
   10  format(f9.2,1x,f9.2,1x,f9.2)
       else
       write(10,20) x,y,z
   20  format(f9.2,1x,f9.2,1x,f9.2,",")
       end if
c
  100  continue
       return
       end
c-------------------------------------
       subroutine coordp2(nx,ny,p)
c-------------------------------------
       dimension p(1)
c
       do 100 i=1,nx
       do 100 j=1,2
       j1=j+ny-1
c
       i1=3*(i-1)+1+3*nx*(j1-1)
       i2=i1+1
       i3=i1+2
       x=p(i1)
       y=p(i2)
       z=p(i3)
c
       if(i.eq.nx.and.j.eq.2) then
       write(10,10) x,y,z
   10  format(f9.2,1x,f9.2,1x,f9.2)
       else
       write(10,20) x,y,z
   20  format(f9.2,1x,f9.2,1x,f9.2,",")
       end if
c
  100  continue
       return
       end
c-------------------------------------------
       subroutine coordp3(nx,ny,p,rd)
c                 * bottom tuki *
c-------------------------------------------
       dimension p(1)
c
       do 100 i=1,nx
       do 100 j=1,2
       j1=j+ny-1
c
       i1=3*(i-1)+1+3*nx*(j1-1)
       i2=i1+1
       i3=i1+2
       x=p(i1)
       y=p(i2)
       z=p(i3)
c
       write(10,20) x,y,z
   20  format(f9.2,1x,f9.2,1x,f9.2,",")
c
  100  continue
c
c----( bottom no chusin )
c
       i1=3*nx*2+1
       i2=i1+1
       i3=i1+2
       x=p(i1)
       y=p(i2)
       z=p(i3)
c
       write(10,110) x,y,z
  110  format(f9.2,1x,f9.2,1x,f9.2)
c
       return
       end
c-------------------------------------------
       subroutine coordp4(nx,ny,q,rd,k,p1)
c                 * bottom tuki *
c-------------------------------------------
       dimension q(1)
       dimension p1(1)
c
       do 100 i=1,nx
       do 100 j=1,2
c
       i1=3*(i-1)+1+3*nx*(j-1)
       i2=i1+1
       i3=i1+2
       x=q(i1)
       y=q(i2)
       z=q(i3)
c
       write(10,20) x,y,z
   20  format(f9.2,1x,f9.2,1x,f9.2,",")
c
  100  continue
c
c----( bottom no chusin )
       x=p1(1)
       y=p1(2)
       z=p1(3)
c
       write(10,30) x,y,z
   30  format(f9.2,1x,f9.2,1x,f9.2,",")
c
c----( cap no chusin )
       x=p1(4)
       y=p1(5)
       z=p1(6)
c
       write(10,40) x,y,z
   40  format(f9.2,1x,f9.2,1x,f9.2)
c
       return
       end
c-------------------------------
       subroutine coorden1(nx)
c-------------------------------
       dimension ia(9000)
       write(10,21)
   21  format("]")
       write(10,22)
   22  format("}")
       write(10,23)
   23  format("colorPerVertex TRUE")
       write(10,24)
   24  format("coordIndex [")
c
       nx2=nx*2
       do 100 i=1,nx2
       i1=1+4*(i-1)
       i2=2+4*(i-1)
       i3=3+4*(i-1)
       i4=4+4*(i-1)
       ia(i1)=0+i-1
       ia(i2)=1+i-1
       ia(i3)=2+i-1
       ia(i4)=-1
  100  continue
c
       jj=4*(nx-1)*2-1
       write(10,102) (ia(i),i=1,jj)
  102  format(8(3i2,i3),2i2,2i3,i2,3i3,88i3,2i3,i4,i3,i3,2i4,i3,
     1        398(3i4,i3),/500(3i4,i3),/2i4,i5,i3,i4,2i5,i3,
     2        /500(3i5,i3),/500(3i5,i3),/500(3i5,i3),/500(3i5,i3))
       return
       end
c-----------------------------------
       subroutine coorden2(nx)
c                 * bottom tuki *
c-----------------------------------
       dimension ia(9000)
       write(10,21)
   21  format("]")
       write(10,22)
   22  format("}")
       write(10,23)
   23  format("colorPerVertex TRUE")
       write(10,24)
   24  format("coordIndex [")
c
       nx2=nx*2
       do 100 i=1,nx2
       i1=1+4*(i-1)
       i2=2+4*(i-1)
       i3=3+4*(i-1)
       i4=4+4*(i-1)
       ia(i1)=0+i-1
       ia(i2)=1+i-1
       ia(i3)=2+i-1
       ia(i4)=-1
  100  continue
c
       jj=4*(nx-1)*2
       write(10,102) (ia(i),i=1,jj)
  102  format(8(3i2,i3),2i2,2i3,i2,3i3,88i3,2i3,i4,i3,i3,2i4,i3,
     1        398(3i4,i3),/500(3i4,i3),/2i4,i5,i3,i4,2i5,i3,
     2        /500(3i5,i3),/500(3i5,i3),/500(3i5,i3),/500(3i5,i3))
c
       write(10,103) ia(jj-2),ia(jj-1),ia(1)
  103  format(3i5," -1")
       write(10,104) ia(jj-1),ia(1),ia(2)
  104  format(3i5," -1")
c
c---- bottom
       nx2=nx*2
       do 200 i=1,nx
       i1=1+4*(i-1)
       i2=2+4*(i-1)
       i3=3+4*(i-1)
       i4=4+4*(i-1)
       ia(i1)=0+2*(i-1)
       ia(i2)=ia(i1)+2
       ia(i3)=nx2
       ia(i4)=-1
  200  continue
c
       jj=4*(nx-1)
       write(10,202) (ia(i),i=1,jj)
  202  format(500(3i4,i3),/500(3i4,i3),/500(3i5,i3),/500(3i5,i3))
c
       write(10,203) ia(jj-2),ia(1),nx2
  203  format(3i4," -1")
c
c---- cap
       nx2=nx*2
       do 300 i=1,nx
       i1=1+4*(i-1)
       i2=2+4*(i-1)
       i3=3+4*(i-1)
       i4=4+4*(i-1)
       ia(i1)=1+2*(i-1)
       ia(i2)=ia(i1)+2
       ia(i3)=nx2
       ia(i4)=-1
  300  continue
c
       jj=4*(nx-1)
       write(10,302) (ia(i),i=1,jj)
  302  format(500(3i4,i3),/500(3i4,i3),/500(3i5,i3),/500(3i5,i3))
c
       write(10,303) ia(jj-2),ia(1),nx2
  303  format(3i4," -1")
c
       return
       end
c-----------------------------------
       subroutine coorden3(nx)
c                 * bottom tuki *
c                 * 1 color     *
c-----------------------------------
       dimension ia(9000)
       write(10,21)
   21  format("]")
       write(10,22)
   22  format("}")
       write(10,23)
   23  format("colorPerVertex FALSE")
       write(10,24)
   24  format("coordIndex [")
c
       nx2=nx*2
       do 100 i=1,nx2
       i1=1+4*(i-1)
       i2=2+4*(i-1)
       i3=3+4*(i-1)
       i4=4+4*(i-1)
       ia(i1)=0+i-1
       ia(i2)=1+i-1
       ia(i3)=2+i-1
       ia(i4)=-1
  100  continue
c
       jj=4*(nx-1)*2
       write(10,102) (ia(i),i=1,jj)
  102  format(8(3i2,i3),2i2,2i3,i2,3i3,88i3,2i3,i4,i3,i3,2i4,i3,
     1        398(3i4,i3),/500(3i4,i3),/2i4,i5,i3,i4,2i5,i3,
     2        /500(3i5,i3),/500(3i5,i3),/500(3i5,i3),/500(3i5,i3))
c
       write(10,103) ia(jj-2),ia(jj-1),ia(1)
  103  format(3i5," -1")
       write(10,104) ia(jj-1),ia(1),ia(2)
  104  format(3i5," -1")
c
c---- bottom
       nx2=nx*2
       do 200 i=1,nx
       i1=1+4*(i-1)
       i2=2+4*(i-1)
       i3=3+4*(i-1)
       i4=4+4*(i-1)
       ia(i1)=0+2*(i-1)
       ia(i2)=ia(i1)+2
       ia(i3)=nx2
       ia(i4)=-1
  200  continue
c
       jj=4*(nx-1)
       write(10,202) (ia(i),i=1,jj)
  202  format(500(3i4,i3),/500(3i4,i3),/500(3i5,i3),/500(3i5,i3))
c
       write(10,203) ia(jj-2),ia(1),nx2
  203  format(3i4," -1")
c
c---- cap
       nx21=nx*2+1
       do 300 i=1,nx
       i1=1+4*(i-1)
       i2=2+4*(i-1)
       i3=3+4*(i-1)
       i4=4+4*(i-1)
       ia(i1)=1+2*(i-1)
       ia(i2)=ia(i1)+2
       ia(i3)=nx21
       ia(i4)=-1
  300  continue
c
       jj=4*(nx-1)
       write(10,302) (ia(i),i=1,jj)
  302  format(500(3i4,i3),/500(3i4,i3),/500(3i5,i3),/500(3i5,i3))
c
       write(10,303) ia(jj-2),ia(1),nx21
  303  format(3i4," -1")
c
       return
       end
c----------------------------------
       subroutine coorden5(nx,ny1)
c----------------------------------
       dimension ia(9000)
       write(10,21)
   21  format("]")
       write(10,22)
   22  format("}")
       write(10,23)
   23  format("colorPerVertex TRUE")
       write(10,24)
   24  format("coordIndex [")
c
cc      nx2=(nx-1)*2
       nx2=nx*2
       do 200 j=1,ny1
c
       do 100 i=1,nx2
       i1=1+4*(i-1)
       i2=2+4*(i-1)
       i3=3+4*(i-1)
       i4=4+4*(i-1)
       ia(i1)=(j-1)*2*nx+0+i-1
       ia(i2)=(j-1)*2*nx+1+i-1
       ia(i3)=(j-1)*2*nx+2+i-1
       ia(i4)=-1
  100  continue
c
       jj=4*(nx-1)*2-1
       write(10,102) (ia(i),i=1,jj)
c 102  format(8(3i2,i3),2i2,2i3,i2,3i3,88i3,2i3,i4,i3,i3,2i4,i3,
c    1        398(3i4,i3),/500(3i4,i3),/2i4,i5,i3,i4,2i5,i3,
  102  format(250(3i7,i3),/250(3i7,i3),/250(3i7,i3),/250(3i7,i3),
     1        /250(3i7,i3),/250(3i7,i3),/250(3i7,i3),/250(3i7,i3),
     2        /250(3i7,i3),/250(3i7,i3),/250(3i7,i3),/250(3i7,i3),
     3        /250(3i7,i3),/250(3i7,i3),/250(3i7,i3),/250(3i7,i3),
     4        /250(3i7,i3),/250(3i7,i3),/250(3i7,i3),/250(3i7,i3),
     5        /250(3i7,i3),/250(3i7,i3),/250(3i7,i3),/250(3i7,i3),
     6        /250(3i7,i3),/250(3i7,i3),/250(3i7,i3),/250(3i7,i3),
     7        /250(3i7,i3),/250(3i7,i3),/250(3i7,i3),/250(3i7,i3),
     8        /250(3i7,i3),/250(3i7,i3),/250(3i7,i3),/250(3i7,i3))
c
  200  continue
       return
       end
c------------------------
       subroutine faceen
c------------------------
       write(10,20)
   20  format("]")
       write(10,21)
   21  format("solid FALSE",/"}")
       write(10,22)
   22  format("appearance Appearance {")
       write(10,23)
   23  format("material Material {")
       write(10,24)
   24  format("transparency 0.000000",/"}",/"}")
       write(10,25)
   25  format("}")
       return
       end
c--------------------------
       subroutine faceen2
c--------------------------
       write(10,20)
   20  format("]")
       write(10,21)
   21  format("solid FALSE",/"}")
       write(10,25)
   25  format("}")
       return
       end
c--------------------------------------
       subroutine pointlight(px,py,pz)
c--------------------------------------
       write(10,20)
   20  format("PointLight {")
       write(10,21) px,py,pz
   21  format("location ",f8.2,f8.2,f8.2)
       write(10,22)
   22  format("}")
       return
       end
c-----------------------------------------
       subroutine directlight(px,py,pz)
c-----------------------------------------
       write(10,20)
   20  format("DirectionalLight {")
       write(10,21) px,py,pz
   21  format("direction ",f8.2,f8.2,f8.2)
       write(10,22)
   22  format("}")
       return
       end
c-------------------------------------
       subroutine lineset1(nx,ny,u,p)
c-------------------------------------
       dimension p(1),u(1)
       ny1=ny-1
c
       do 10 j=1,ny
       call line1(nx,j,u,p)
   10  continue
c
       return
       end
c-------------------------------------
       subroutine line1(nx,ny,u,p)
c-------------------------------------
       dimension p(1),u(1)
c
       call linebe
       call colorp1(nx,ny,u)
       call coordbe
       call coordp1(nx,ny,p)
       call lineen(nx)
c
       return
       end
c------------------------
       subroutine linebe
c------------------------
       write(10,21)
   21  format("Shape {")
       write(10,22)
   22  format("geometry IndexedLineSet {")
       write(10,23)
   23  format("color Color {")
       write(10,24)
   24  format("color [")
       return
       end
c-------------------------------
       subroutine lineen(nx)
c-------------------------------
       dimension ia(9000)
c
       do 10 i=1,9000
       ia(i)=i-1
   10  continue
c
       write(10,21)
   21  format("]")
       write(10,22)
   22  format("}")
       write(10,24)
   24  format("coordIndex [")
c
       write(10,25) (ia(i),i=1,nx)
   25  format(10i2,90i3,900i4/(2000i5))
c
       write(10,27)
   27  format("]")
       write(10,29)
       write(10,29)
   29  format("}")
       return
       end
c----------------------------------------
       subroutine imagetx(nx,ny,p,ch1,n)
c----------------------------------------
       dimension p(1),u(1)
       ny1=ny-1
c
       do 10 j=1,ny1
       call image1(nx,j,p,ch1,n)
   10  continue
c
       return
       end
c---------------------------------------
       subroutine image1(nx,ny,p,ch1,n)
c---------------------------------------
       dimension p(1),u(1)
c
       call imagebe(ch1,n)
       call coordp2(nx,ny,p)
       call coorden1(nx)
       call faceen
c
       return
       end
c-------------------------------
      subroutine imagebe(chr,n)
c-------------------------------
       character chr*15,ica*15,ich(15)*1
       equivalence (ica,ich)
       ica=chr
       write(10,21)
   21  format("Shape {")
       write(10,22)
   22  format("appearance Appearance {")
       write(10,23)
   23  format("texture ImageTexture {")
   24  write(10,*) "url",'"',(ich(i),i=1,n),'"'
       write(10,25)
   25  format("}",/"}")
       write(10,26)
   26  format("geometry IndexedFaceSet {")
       write(10,27)
   27  format("coord Coordinate {")
       write(10,28)
   28  format("point [")
       return
       end
c----------------------------------------
       subroutine movietx(nx,ny,p,ch1,n)
c----------------------------------------
       dimension p(1),u(1)
       ny1=ny-1
c
       do 10 j=1,ny1
       call movie1(nx,j,p,ch1,n)
   10  continue
c
       return
       end
c---------------------------------------
       subroutine movie1(nx,ny,p,ch1,n)
c---------------------------------------
       dimension p(1),u(1)
c
       call moviebe(ch1,n)
       call coordp2(nx,ny,p)
       call coorden1(nx)
       call faceen
c
       return
       end
c-------------------------------
      subroutine moviebe(chr,n)
c-------------------------------
       character chr*15,ica*15,ich(15)*1
       equivalence (ica,ich)
       ica=chr
       write(10,21)
   21  format("Shape {")
       write(10,22)
   22  format("appearance Appearance {")
       write(10,23)
   23  format("texture MovieTexture {")
   24  write(10,*) "url",'"',(ich(i),i=1,n),'"'
       write(10,30)
cc 30  format("loop TRUE",/"startTime 0")
   30  format("loop FALSE",/"startTime 0",/"stopTime 0")
       write(10,25)
   25  format("}",/"}")
       write(10,26)
   26  format("geometry IndexedFaceSet {")
       write(10,27)
   27  format("coord Coordinate {")
       write(10,28)
   28  format("point [")
       return
       end
c-----------------------------------------------------------
       subroutine defusem(nx,ny,u,p,x1,y1,z1,x2,y2,z2,r,n)
c----------------------------------------------------------
       dimension p(1),u(1)
       ny1=ny-1
c
       do 10 j=1,ny1
       call defusem1(nx,j,u,p,x1,y1,z1,x2,y2,z2,r,n)
   10  continue
c
       return
       end
c-----------------------------------------------------------
       subroutine defusem1(nx,ny,u,p,x1,y1,z1,x2,y2,z2,r,n)
c-----------------------------------------------------------
       dimension p(1),u(1)
c
       call defface
       call colorp2(nx,ny,u)
       call coordbe
       call coordp2(nx,ny,p)
       call coorden1(nx)
       call faceen
c
       do 10 i=1,n
       call useface(x1,y1,z1,x2,y2,z2,r,i)
   10  continue
c
       return
       end
c--------------------------
       subroutine defface
c--------------------------
       write(10,21)
   21  format("DEF Face Shape {")
       write(10,22)
   22  format("geometry IndexedFaceSet {")
       write(10,23)
   23  format("color Color {")
       write(10,24)
   24  format("color [")
       return
       end
c------------------------------------------------
       subroutine useface(x1,y1,z1,x2,y2,z2,r,i)
c------------------------------------------------
       write(10,21)
   21  format("Transform {")
       write(10,22) x1,y1,z1,r
   22  format("rotation ",f6.2,f6.2,f6.2,f6.2)
       write(10,23) x2,y2*i,z2
   23  format("translation ",f9.2,f9.2,f9.2)
       write(10,24)
   24  format("children USE Face",/"}")
       return
       end
c-----------------------------------------
       subroutine sphere2(p,n1,rd,r,g,b)
c-----------------------------------------
       dimension p(1)
c
       do 20 i=1,n1
c
       i1=3*(i-1)+1
       i2=i1+1
       i3=i1+2
       x=p(i1)
       y=p(i2)
       z=p(i3)
c
       call sphere(x,y,z,r,g,b,rd)
c
   20  continue
c
       return
       end
c----------------------------------------
       subroutine sphere(x,y,z,r,g,b,rd)
c----------------------------------------
       write(10,20)
   20  format("Transform {")
       write(10,21) x,y,z
   21  format("translation ",f9.2,f9.2,f9.2)
       write(10,22)
   22  format("children [")
       write(10,23)
   23  format("Shape {")
       write(10,24)
   24  format("appearance Appearance {")
       write(10,25)
   25  format("material Material {")
       write(10,26)
   26  format("transparency 0.000000")
       write(10,27) r,g,b
   27  format("diffuseColor ",f5.2,f5.2,f5.2)
       write(10,28)
   28  format("}",/"}")
       write(10,29)
   29  format("geometry Sphere {")
       write(10,30) rd
   30  format("radius ",f6.2)
       write(10,31)
   31  format("}",/"}",/"]",/"}")
c
       return
       end
c-------------------------------------------------------
       subroutine cylinder1(p,n1,rx,ry,rz,dd,rd,h,r,g,b)
c-------------------------------------------------------
       dimension p(1)
c
       do 20 i=1,n1
c
       i1=3*(i-1)+1
       i2=i1+1
       i3=i1+2
       x=p(i1)
       y=p(i2)
       z=p(i3)
c
       call cylinder(x,y,z,rx,ry,rz,dd,rd,h,r,g,b)
c
   20  continue
c
       return
       end
c-----------------------------------------------
       subroutine cylinderm2(p,n1,rd,r,g,b,h)
c-----------------------------------------------
       dimension p(1)
       rx=0.0
       ry=0.0
       rz=0.0
       dd=0.78539
c
       do 20 i=1,n1
c
       i1=3*(i-1)+1
       i2=i1+1
       i3=i1+2
       x=p(i1)
       y=p(i2)
       z=p(i3)
c
       x1=p(i1+3)
       y1=p(i2+3)
       z1=p(i3+3)
c
       x2=abs(x1-x)
       y2=abs(y1-y)
       z2=abs(z1-z)
c
c---<< x houkou >>
       if(x2.gt.y2.and.x2.gt.z2) then
          rz=-1
          if(z2.gt.y2) then
              rx=1
          end if
       end if
c---<< y houkou >>
c      if(y2.gt.z2.and.y2.gt.x2) then
c                rx=-1
c         else
c                rx=1
c         end if
c      end if
c---<< z houkou >>
       if(z2.gt.x2.and.z2.gt.y2) then
          if(x2.lt.y2) then
              rx=-1
          else
              rx=1
          end if  
       end if
c
       call cylinder(x,y,z,rx,ry,rz,dd,rd,h,r,g,b)
c      call def1(x,y,z,rx,ry,rz,dd,rd,h,r,g,b)
c
   20  continue
c
   99  continue
c
       return
       end
c-----------------------------------------------------------
       subroutine cylinder(cx,cy,cz,rx,ry,rz,dd,rd,t,r,g,b)
c-----------------------------------------------------------
       write(10,20)
   20  format("Transform {")
       write(10,21) rx,ry,rz,dd
   21  format("rotation ",f7.2,f7.2,f7.2,f7.4)
       write(10,22) cx,cy,cz
   22  format("translation ",f7.2,f7.2,f7.2)
       write(10,23)
   23  format("children Shape {")
       write(10,24)
   24  format("appearance Appearance {")
       write(10,25)
   25  format("material Material {")
       write(10,26)
   26  format("transparency 0.000000")
       write(10,27) r,g,b
   27  format("diffuseColor",f5.2,f5.2,f5.2)
       write(10,28)
   28  format("}",/"}")
       write(10,29)
   29  format("geometry Cylinder {")
       write(10,30) rd
   30  format("radius",f7.2)
       write(10,31) t
   31  format("height",f7.2)
       write(10,32)
   32  format("}",/"}",/"}")
c
       return
       end
c-------------------------------------------------------
       subroutine defl(cx,cy,cz,rx,ry,rz,dd,rd,t,r,g,b)
c-------------------------------------------------------
       write(10,20)
   20  format("Transform {")
       write(10,21) rx,ry,rz,dd
   21  format("rotation ",f9.2,f9.2,f9.2,f9.2)
       write(10,22) cx,cy,cz
   22  format("translation ",f9.2,f9.2,f9.2)
       write(10,23)
   23  format("children DEF def1 Shape {")
       write(10,24)
   24  format("appearance Appearance {")
       write(10,25)
   25  format("material Material {")
       write(10,26)
   26  format("transparency 0.000000")
       write(10,27) r,g,b
   27  format("diffuseColor",f5.2,f5.2,f5.2)
       write(10,28)
   28  format("}",/"}")
       write(10,29)
   29  format("geometry Cylinder {")
       write(10,30) rd
   30  format("radius",f8.2)
       write(10,31) t
   31  format("height",f8.2)
       write(10,32)
   32  format("}",/"}",/"}")
c
       return
       end
c------------------------------------------------
       subroutine use1(cx,cy,cz,rx,ry,rz,dd)
c------------------------------------------------
       write(10,20)
   20  format("Transform {")
       write(10,21) rx,ry,rz,dd
   21  format("rotation ",f9.2,f9.2,f9.2,f9.2)
       write(10,22) cx,cy,cz
   22  format("translation ",f9.2,f9.2,f9.2)
       write(10,23)
   23  format("children USE def1")
       write(10,32)
   32  format("}")
c
       return
       end
c---------------------------
       subroutine initvrml
c---------------------------
       write(10,10)
   10  format("#VRML V2.0 utf8")
       return
       end
