SUBROUTINE VPSYM(A)
      INTEGER*2 A(2)
      INTEGER*2 ANPTS,ATYPE,AXA,AXF,AXI,AXMIN,ADELX
      INTEGER*2 AYA,AYF,AYI,AEA,AJOIN,AOFF
      INTEGER*2 AXP,AYP,AEP,AXC,AYC,AEC,AXN,AYN,AEN,AIC
      COMMON/VAOFF/ANPTS,ATYPE,AXA,AXF,AXI,AYA,AYF,AYI,AEA,AJOIN,AOFF,
     1             AXP,AYP,AEP,AXC,AYC,AEC,AXN,AYN,AEN,AIC
      EQUIVALENCE (AXA,AXMIN),(AXF,ADELX)
      REAL*4    XFAC,XOFF
      INTEGER*2 XTYPE,XMAXB,XSMINB,XSMAXB,XSNOWB
      COMMON/VXDES/XFAC,XOFF,XTYPE,XMAXB,XSMINB,XSMAXB,XSNOWB
      REAL*4    YFAC,YOFF
      INTEGER*2 YTYPE,YMINB,YMAXB
      COMMON/VYDES/YFAC,YOFF,YTYPE,YMINB,YMAXB
      INTEGER*2 XL,YL,EL,XH,YH,EH,YP
      INTEGER*2 IC
      LOGICAL*1 C(2)
      EQUIVALENCE (IC,C(1))
      XL=A(AXC)
      YL=A(AYC)
      EL=A(AEC)
      XH=A(AXN)
      YH=A(AYN)
      EH=A(AEN)
      ID=A(AIC)+1
1000  CONTINUE
      IF((YL.LT.YMINB).OR.(YL.GT.YMAXB))GO TO 1200
      IF(A(AEA).EQ.0) GO TO 1100
      IYLOW=YL-EL
      IYHIGH=YL+EL
      IF(IYLOW.LT.YMINB)IYLOW=YMINB
      IF(IYLOW.GT.YMAXB)IYLOW=YMAXB
      IF(IYHIGH.LT.YMINB)IYHIGH=YMINB
      IF(IYHIGH.GT.YMAXB)IYHIGH=YMAXB
      IF((IYHIGH-IYLOW).LT.6)GO TO 1100
      IF(XSNOWB.EQ.XL)GO TO 1020
      CALL VSBSET(IYLOW)
      CALL VSBSET(IYHIGH)
      GO TO 1100
1020  CALL VBSET(IYLOW,YL-3)
      CALL VBSET(YL+3,IYHIGH)
1100  CONTINUE
      YP=YL
      IF(YP.LT.YMINB)YP=YMINB
      IF(YP.GT.YMAXB)YP=YMAXB
      IC=A(AJOIN)
      ICHR=C(1)
      IF(ICHR.NE.0)CALL VSETBC(ICHR,XSNOWB-XL,YP)
1200  IF((XH.GT.(XSNOWB+2)).OR.(ID.GT.A(ANPTS)))GO TO 2000
      XL=XH
      YL=YH
      EL=EH
      ID=ID+1
      CALL VGETXY(A,ID,XH,YH,EH)
      GO TO 1000
2000  IF(XSNOWB.LT.(A(AXC)+2))GO TO 3000
      IF(A(AIC).GE.A(ANPTS))GO TO 2030
      DO 2010 I=AXP,AEC
2010  A(I)=A(I+3)
      A(AIC)=A(AIC)+1
      CALL VGETXY(A,A(AIC)+1,A(AXN),A(AYN),A(AEN))
      GO TO 2000
2030  DO 2040 I=AXP,AYN
2040  A(I)=32767
3000  RETURN
      END