subroutine formshp2(istyp,ivecact)
      use winteracter

      include 'D.inc'
      
      COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL 
      character*1 ai1a,ai1b,ai1c,ai1d,label,ai1f
      character*3 sub
      character*4 ai1,ai7,aai7,ai8,ai9,anrs,aii,aioff
      character*10 as
      character*11 name
      character*80 headr
      character*255 fnamein,filter
      integer*2 i3s,i4s
      integer status,i1,i2,i3,i4,i5,i6,i7,i8,i9,ia1,ia7,ia8,ia9,nrs&
      ,nars,ii,ioff,iaoff,i1a,i1b,i1c,i1d,istyp,nptemp
      integer*8 i88
      real*8 fp1,fp2,fp3,fp4,fp5,fp6,fp7,fp8,bx(1000),by(1000),bm(1000)&
            ,bxmn,bymn,bxmx,bymx,bmmn,bmmx,axmn,aymn,axmx,aymx,fz,ammn,ammx
      real bed,val
      integer ityp,icl
      allocatable bed(:),val(:,:),ityp(:),icl(:)

      LOGICAL OPENED
      equivalence(ai1,ia1),(ai7,ia7),(aii,ii),(anrs,nrs),(aioff,ioff)

      if(.not. allocated(bed)) then
        allocate (bed(250000),val(250000,4),ityp(250000),icl(250000))
        bed=0.
        val=0.
        ityp=0
        icl=0
      endif
      filter='Shape file *.shp|*.shp|'
      INQUIRE(99,opened= OPENED)   
	  IF( .NOT. OPENED) THEN
        CALL WSelectFile(filter,SaveDialog+PromptOn+AppendExt,FNAMEIN,'Shapefile Name')
        IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
      
          open(99,file=fnamein,form='binary')
          sub='shx'
          call ADDSUB(fnamein,sub)
          open(98,file=fnamein,form='binary')
          sub='dbf'
          call ADDSUB(fnamein,sub)
          open(97,file=fnamein,form='binary')
        ELSE
          RETURN
        ENDIF
      ENDIF
!   read data file to establish sizes and max/min
      nfils=50
      axmn=1.e36
      aymn=1.e36
      ammn=1.e36
      axmx=-1.e36
      aymx=-1.e36
      ammx=-1.e36
!      if(ivecact .ne. 1) then
!        read(70,'(a80)') headr
!        read(70,'(a80)') headr
!        read(headr(9:16),'(i8)') istyp
!      endif
      do i=1,250000
!        if(istyp .eq. 25) then
        if(istyp .eq. 15) then
          read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts)
          icl(i)=iclt
!          write(155,*) icl(i),ityp(i),npts
          do j=1,npts
            axmn=min(axmn,bx(j))
            aymn=min(aymn,by(j))
            ammn=min(ammn,bm(j))
            axmx=max(axmx,bx(j))
            aymx=max(aymx,by(j))
            ammx=max(ammx,bm(j))
          enddo
!   NEED TO FIX THIS
          nfils=nfils+36+12*npts
!   NEED TO FIX THIS
        elseif(istyp .eq. 5) then
          IF(IVECACT .EQ.  5) THEN
            read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts)
          ELSE
            read(113,end=100) iclt,npts,(bx(j),by(j),j=1,npts)
          ENDIF
          icl(i)=iclt
          do j=1,npts
            axmn=min(axmn,bx(j))
            aymn=min(aymn,by(j))
            axmx=max(axmx,bx(j))
            aymx=max(aymx,by(j))
          enddo
          ammn=0.
          ammx=0.
          nfils=nfils+28+8*npts
        elseif(istyp .eq. 3) then
          read(113,end=100) npts,(bx(j),by(j),j=1,npts),d1
          do j=1,npts
            axmn=min(axmn,bx(j))
            aymn=min(aymn,by(j))
            axmx=max(axmx,bx(j))
            aymx=max(aymx,by(j))
          enddo
          ammn=0.
          ammx=0.
          nfils=nfils+28+8*npts
        elseif(istyp .eq. 1 .and.  ivecact .eq. 0) then
          read(70,9875,end=100) bx(1),by(1)
 9875     format(10x,2f20.0,f10.0)          
          axmn=min(axmn,bx(1))
          aymn=min(aymn,by(1))
          axmx=max(axmx,bx(1))
          aymx=max(aymx,by(1))
          ammn=0.
          ammx=0.
          nfils=nfils+14
        elseif(istyp .eq. 1 .and.  ivecact .eq. 1) then
!          read(113,end=100) NR,bxt,byt,d1,d2,d3,d4,d5,d6
          read(113,end=100) NR,bxt,byt,d1,d2,d3,d4
 9874     format(9x,8f14.0)          
          axmn=min(axmn,bxt)
          aymn=min(aymn,byt)
          axmx=max(axmx,bxt)
          aymx=max(aymx,byt)
          ammn=0.
          ammx=0.
          nfils=nfils+14
        elseif(istyp .eq. 1 .and.  ivecact .eq. 6) then
          read(113,end=100) NR,bx(1),by(1),d1
          axmn=min(axmn,bx(1))
          aymn=min(aymn,by(1))
          axmx=max(axmx,bx(1))
          aymx=max(aymx,by(1))
          ammn=0.
          ammx=0.
          nfils=nfils+14
        endif
        numdat=i
      enddo
  100 rewind 113

!      read(70,'(a80)') headr
!c      if(ivecact .eq. 1) read(70,'(a80)') headr
!c   setup header
      ia1=9994
      call BTOL(ai1,i1)
      i2=0
      i3=0
      i4=0
      i5=0
      i6=0
      ia7=nfils
      call BTOL(ai7,i7)
      i8=1
      i9=istyp
      fz=0.
      if(istyp .ne. 15) then
        write(99) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,fz,fz,ammn,ammx
      else  
        write(99) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,ammn,ammx,fz,fz
      endif  
      ia7=50+4*numdat
      call BTOL(ai7,i7)
!ipk nov20      
      if(istyp .ne. 15) then
        write(98) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,fz,fz,ammn,ammx
      else
        write(98) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,ammn,ammx,fz,fz
      endif
      ioff=50
      
!     header now complete for shp and shx options      
      do i=1,numdat
!ipk nov20      
        if(istyp .eq. 15) then
          read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts)
          icl(i)=iclt
          nrs=32+12*npts
          nrsc=nrs+4
          write(155,*) 'nrs',nrs,npts
          call btol(anrs,nars)
        elseif(istyp .eq. 5) then
          IF(IVECACT .EQ.  5) THEN
            read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts)
          ELSE
            read(113) iclt,npts,(bx(j),by(j),j=1,npts)
          ENDIF
          icl(i)=iclt
          nrs=24+8*npts
          nrsc=nrs+4
!          write(155,*) 'nrs',nrs
          call btol(anrs,nars)
        elseif(istyp .eq. 3) then
          read(113) npts,(bx(j),by(j),j=1,npts),val(i,1)
          icl(i)=iclt
          nrs=24+8*npts
          nrsc=nrs+4
!          write(155,*) 'nrs',nrs
          call btol(anrs,nars)
        elseif(istyp .eq. 1) then
          if(ivecact .eq. 0) then
            read(70,9875) bx(1),by(1),bed(i)
          elseif(ivecact .eq. 6) then
            read(113) ityp(i),bx(1),by(1),val(i,1)
          else
            read(113) idum,bxt,byt,(val(i,j),j=1,4)
            bx(1)=bxt
            by(1)=byt
          endif
          nrs=10
          nrsc=14
!          write(155,*) 'nrs',nrs
          call btol(anrs,nars)
        endif
        ii=i
        call btol(aii,nrec)
        write(99) nrec,nars
!ipk nov20        
        if(istyp .eq. 15) then
  	  	  j1=istyp
          j2=1
          bxmn=bx(1)
          bymn=by(1)
          bmmn=bm(1)
          bxmx=bx(1)
          bymx=by(1)
          bmmx=bm(1)
          do k=2,npts
            bxmn=min(bxmn,bx(k))
            bymn=min(bymn,by(k))
            bmmn=min(bmmn,bm(k))
            bxmx=max(bxmx,bx(k))
            bymx=max(bymx,by(k))
            bmmx=max(bmmx,bm(k))
          enddo
          j3=npts
          j4=I
!          write(99) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4
          write(99) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4
          do k=1,npts
		    write(99) bx(k),by(k) 
          enddo
          write(99) bmmn,bmmx
          do k=1,npts
		    write(99) bm(k) 
          enddo
          
!          write(99) bmmn,bmmx
!          do k=1,npts
!		    write(99) bm(k) 
!          enddo

          
        elseif(istyp .gt. 2  .and. istyp .lt. 15) then
		  j1=istyp
          j2=1
          bxmn=bx(1)
          bymn=by(1)
          bxmx=bx(1)
          bymx=by(1)
          do k=2,npts
            bxmn=min(bxmn,bx(k))
            bymn=min(bymn,by(k))
            bxmx=max(bxmx,bx(k))
            bymx=max(bymx,by(k))
          enddo
          j3=npts
          j4=0
          write(99) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4
!          write(155,*) j1,bxmn,bymn,bxmx,bymx,j2,j3,j4
          do k=1,npts
		    write(99) bx(k),by(k) 
!		  write(155,*) k,bx(k),by(k) 
          enddo
          if(istyp .eq. 15) then
            write(99) bmmn,bmmx,(bm(k),k=1,npts)
          endif
        elseif(istyp .eq. 1) then
          j4=1
          write(99) j4,bx(1),by(1) 
        endif
!          write(155,*) ioff,nrs
          call btol(aioff,iaoff)
          write(98) iaoff,nars
          ioff=ioff+nrsc
      enddo
      i1a=3
      i1b=115
      i1c=12
      i1d=9
      ai1a=char(i1a)
      ai1b=char(i1b)
      ai1c=char(i1c)
      ai1d=char(i1d)
      i2=numdat
      if(ivecact .eq. 0  .or.  ivecact .gt. 3) then
        i4s=18
        i3s=97
      elseif(ivecact .eq. 3) then
        i4s=11
        i3s=65
      else
        i4s=37
        i3s=161
      endif
      i5=0
      write(97) ai1a,ai1b,ai1c,ai1d,i2,i3s,i4s,i5
      ai1a=char(0)
      ai1b='W'
      write(97) i5,i5,i5,ai1a,ai1a,ai1b,ai1a
      i2a=0
      IF(ISTYP .EQ. 15) THEN
        name='ID         '
        label='N'
        i2=0
        ai1a=char(9)
        ai1b=char(0)
        ai1c=char(0)
        ai1f=char(13)
        ai1d=char(0)
        write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
        name='Type       '
        label='N'
        i2=0
        ai1a=char(9)
        ai1b=char(0)
        ai1c=char(0)
        ai1f=char(13)
        write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f
      ELSEIF(ISTYP .EQ. 5) THEN
        name='ID         '
        label='N'
        i2=0
        ai1a=char(9)
        ai1b=char(0)
        ai1c=char(0)
        ai1f=char(13)
        ai1d=char(0)
        write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
        name='Contour    '
        label='N'
        i2=0
        ai1a=char(9)
        ai1b=char(2)
        IF(IVECACT .EQ. 5) THEN
          name='TYPE *     '
          label='N'
          ai1b=char(0)
        ENDIF
        ai1c=char(0)
        ai1f=char(13)
        write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f
      elseif(istyp .eq. 3) then
        name='CONTOUR    '
        label='N'
        i2=0
        ai1a=char(10)
        ai1b=char(4)
        ai1c=char(0)
        ai1f=char(13)
        ai1d=char(0)
        write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f
      elseif(istyp .eq. 1) then
        if(ivecact .eq. 6) then
          name='NODE       '
          label='N'
          i2=0
          ai1a=char(8)
          ai1b=char(0)
          ai1c=char(0)
          ai1f=char(13)
          ai1d=char(0)
          write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
          name='Bed Elev   '
          label='F'
          i2=0
          ai1a=char(9)
          ai1b=char(3)
          ai1c=char(0)
          ai1f=char(13)
          write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c,ai1f
        else
          name='VEL        '
          label='N'
          i2=0
          ai1a=char(9)
          ai1b=char(4)
          ai1c=char(0)
          ai1f=char(13)
          ai1d=char(0)
          write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
          name='DIR        '
          label='N'
          i2=0
          ai1a=char(9)
          ai1b=char(2)
          ai1c=char(0)
          ai1f=char(13)
          write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
          name='DEP        '
          label='F'
          i2=0
          ai1a=char(9)
          ai1b=char(3)
          ai1c=char(0)
          ai1f=char(13)
          write(97)name,label,i2,ai1a,ai1b,i2a,i2a,i2a,ai1d,ai1c
          name='WS-ELEV    '
          label='N'
          i2=0
          ai1a=char(9)
          ai1b=char(3)
          ai1c=char(0)
          ai1f=char(13)
          write(97)name,label,i2,ai1a,ai1b,i2,i2,i2,ai1d,ai1c
          write(97)ai1f
        endif
      endif
      ai1a=char(32)
      ai1f=char(32)
      do i=1,numdat
        write(97) ai1a
        if(istyp .eq. 15) then
          write(as(1:9),'(i9)') icl(i)
          write(97) as(1:9)
          write(as(1:9),'(i9)') ityp(i)
          write(97) as(1:9)
        elseif(istyp .eq. 5) then
          write(as(1:8),'(i8)') icl(i)
          write(97) as(1:8)
          if(IVECACT .EQ. 5) then
            write(as(1:9),'(i9)') ityp(i)
            write(97) as(1:9)
          else
            ficl=contur(icl(i))
            write(as(1:9),'(f9.2)') ficl
            write(97) as(1:9)
          endif
        elseif(istyp .eq. 3) then
          write(as(1:10),'(f10.4)') val(i,1)
          write(97) as(1:10)
        elseif(istyp .eq. 1) then
          if(ivecact .eq. 0) then
            write(as(1:8),'(i8)') i
            write(97) as(1:8)
            write(as(1:8),'(f8.2)') bed(i)
            write(97) as(1:8)
          elseif(ivecact .eq. 6) then
            write(as(1:8),'(i8)') ityp(i)
            write(97) as(1:8)
            write(as(1:9),'(f9.2)') val(i,1)
            write(97) as(1:9)
          else
            write(as(1:9),'(f9.4)') val(i,1)
            write(97) as(1:9)
            write(as(1:9),'(f9.2)') val(i,2)
            write(97) as(1:9)
            write(as(1:9),'(f9.3)') val(i,3)
            write(97) as(1:9)
            write(as(1:9),'(f9.3)') val(i,4)
            write(97) as(1:9)
          endif
        endif
      enddo
      ai1a=char(26)
      write(97) ai1a
      close (99)
      close (98)
      close (97)
      return
      end