You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
474 lines
13 KiB
Fortran
474 lines
13 KiB
Fortran
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
|
|
|
|
|