C                  INTERNATIONAL AVS CENTER
C        (This disclaimer must remain at the top of all files)
C
C WARRANTY DISCLAIMER
C
C This module and the files associated with it are distributed free of charge.
C It is placed in the public domain and permission is granted for anyone to use,
C duplicate, modify, and redistribute it unless otherwise noted.  Some modules
C may be copyrighted.  You agree to abide by the conditions also included in
C the AVS Licensing Agreement, version 1.0, located in the main module
C directory located at the International AVS Center ftp site and to include
C the AVS Licensing Agreement when you distribute any files downloaded from
C that site.
C
C The International AVS Center, MCNC, the AVS Consortium and the individual
C submitting the module and files associated with said module provide absolutely
C NO WARRANTY OF ANY KIND with respect to this software.  The entire risk as to
C the quality and performance of this software is with the user.  IN NO EVENT
C WILL The International AVS Center, MCNC, the AVS Consortium and the individual
C submitting the module and files associated with said module BE LIABLE TO
C ANYONE FOR ANY DAMAGES ARISING FROM THE USE OF THIS SOFTWARE, INCLUDING,
C WITHOUT LIMITATION, DAMAGES RESULTING FROM LOST DATA OR LOST PROFITS, OR ANY
C SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES.
C
C This AVS module and associated files are public domain software unless
C otherwise noted.  Permission is hereby granted to do whatever you like with
C it, subject to the conditions that may exist in copyrighted materials. Should
C you wish to make a contribution toward the improvement, modification, or
C general performance of this module, please send us your comments:  why you
C liked or disliked it, how you use it, and most important, how it helps your
C work. We will receive your comments at avs@ncsc.org.
C
C Please send AVS module bug reports to avs@ncsc.org.
C
      subroutine symbol(xpage,ypage,height,ibcd,angle,nchar)
*                ======
*     Standard Calcomp routine
*     ------------------------
C   IAC CODE CHANGE :       include 'cgblock.f'
	INCLUDE 'cgblock.f'
      character ibcd(*)*4
      logical center,nop,penup,exept,calsym,driver,smart
      data calsym / .false. /
      calsym=.true.
*
      entry mark(xpage,ypage,height,ibcd,angle,nchar)
*           ====
* ... "Special" call / centered symbols ...
      inteq=ichar(ibcd(1)(4:4))
      icode=nchar
      center=icode.lt.0 .and. inteq.ge.0 .and. inteq.le.13
* ... Positioning ...
      x=xpage
      y=ypage
* ... Annotation to be continued ...
      if(xpage.eq.999.0) x=xl
      if(ypage.eq.999.0) y=yl
* ... Move with pen up ...
      if(icode.ge.-1) call plot(x,y,3)
* ... Move with pen down ...
      if(icode.le.-2) call plot(x,y,2)
* ... Origin of text ...
      xt=x
      yt=y
*
* ... Hardware characters ...
      if(calsym .and. nchar.gt.0) then
         call cgbtext(smart,height,ibcd,angle,nchar)
         calsym=.false.
         if(smart) return
         calsym=.true.
      endif
*
* ... Height of symbols ...
      div=7.
      if(center) div=4.
      hx=height/div
      hy=height/div
* ... Angle ...
      hoek=angle*atan(1.)/45.
      cosin=cos(hoek)
      sinus=sin(hoek)
*
* ... Transformations ...
      do 5 i=1,12
      hxc(i)=hx*(i-3)*cosin
      hxs(i)=hx*(i-3)*sinus
      hyc(i)=hy*(i-3)*cosin
      hys(i)=hy*(i-3)*sinus
    5 continue
      meest=10
      if(center) meest=7
      hyct=hyc(meest)
      hyst=hys(meest)
      hxct=hxc(meest)
      hxst=hxs(meest)
*
* ... Kind of symbols ...
      length=nchar
      if(icode.le.0) length=1
      do 10 l=1,length
      n=(l-1)/4+1
      k=mod(l-1,4)+1
      letter=ichar(ibcd(n)(k:k))
      if(icode.le.0) letter=inteq
* ... Strokes ...
      call cgbstr(calsym,letter)
* ... Special cases ...
      exept=nodes.eq.1 .and. ixs(1).eq.15
     . .and. iys(1).ge.1 .and. iys(1).le.15
      schaal=1.
      if(exept) call cgbexept(x,y,schaal)
      if(exept) goto 10
*
      penup=.true.
      do 20 i=1,nodes
         nop=ixs(i).eq.15 .and. iys(i).eq.0
         if(nop) goto 20
* ...    Transformations ...
         ii=ixs(i)+1
         jj=iys(i)+1
         xx=x+schaal*(hxc(ii)-hys(jj))
         yy=y+schaal*(hxs(ii)+hyc(jj))
* ...    Plotting ...
         kode=2
         if(penup) kode=3
         call plot(xx,yy,kode)
   20 penup=nop
      x=x+schaal*hxct
      y=y+schaal*hxst
*
   10 if(.not.center) call plot(x,y,3)
*
* ... Finally ...
      calsym=.false.
      return
      end