iank
/
RMAGEN84
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity
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.
master
Branches Tags
${ item.name }
Create tag ${ searchTerm }
Create branch ${ searchTerm }
from 'b7daddabce'
${ noResults }
RMAGEN84/SRC84/FORMSHP.F90

455 lines
12 KiB
Fortran
Raw Normal View History Unescape Escape

VERSION84 WITH NEW GRID PLOTTING AND 1D EXPANSION
5 years ago
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
read(113,end=100) iclt,ityp(i),npts,(bx(j),by(j),bm(j),j=1,npts)
do j=1,npts
write(155,*) bx(j),by(j),bm(j)
enddo
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.
write(99) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,fz,fz,ammn,ammx
ia7=50+4*numdat
call BTOL(ai7,i7)
write(98) i1,i2,i3,i4,i5,i6,i7,i8,i9,axmn,aymn,axmx,aymx,fz,fz,ammn,ammx
ioff=50
! header now complete for shp and shx options
do i=1,numdat
if(istyp .eq. 25) 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
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
if(istyp .eq. 25) 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=0
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
elseif(istyp .gt. 2) 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
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. 25) THEN
name='ID '
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='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(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='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. 25) then
write(as(1:8),'(i8)') icl(i)
write(97) as(1:8)
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