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.
284 lines
7.0 KiB
Fortran
284 lines
7.0 KiB
Fortran
SUBROUTINE READSHP
|
|
USE WINTERACTER
|
|
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
include 'd.inc'
|
|
character*4 temp
|
|
character*100 header
|
|
character*256 field
|
|
character*4 ai7,aai7,ai8
|
|
integer status,i1,i2,i3,i4,i5,i6,i7,i8,i9
|
|
integer*2 i1s,i2s,i3s
|
|
integer*1 i1vs(20),i2vs(20)
|
|
real*8 fp1,fp2,fp3,fp4,fp5,fp6,fp7,fp8,vtemp(20)
|
|
character*11 label(20),fomat(20)
|
|
character*1 type(20),a2,a3,a4
|
|
character*2 a32
|
|
equivalence (aai7,ia7),(aai8,ia8)
|
|
|
|
c read header
|
|
|
|
read(113) i1,i2,i3,i4,i5,i6,ai7,i8,i9
|
|
IF(I9 .EQ. 5) THEN
|
|
REWIND 113
|
|
CALL RDSHP5(113)
|
|
GO TO 600
|
|
ENDIF
|
|
read(113) fp1,fp2,fp3,fp4,fp5,fp6,fp7,fp8
|
|
CALL BTOL(AI7,IA7)
|
|
write(90,*) 'file length',ia7
|
|
write(90,*) 'version',i8
|
|
write(90,*) 'shapetype',i9
|
|
|
|
c read data
|
|
IASK=0
|
|
read(114) i1,i2,i1s,i2s,i3,i4,i5,i6,i7
|
|
nrecs=i2
|
|
nbytesh=i1s
|
|
nrecsh=nbytesh/32-1
|
|
ndytesrec=i2s
|
|
nfl=0
|
|
|
|
c now process labels
|
|
|
|
do k=1,nrecsh
|
|
read(114) label(k),type(k),i3,i1vs(k),i2vs(k),i3s,i4,i5,i6
|
|
if(type(k) .eq. 'F' .or. type(k) .eq. 'N') then
|
|
if(i2vs(k) .gt. 9) then
|
|
write(fomat(k),5999) i1vs(k),i2vs(k)
|
|
5999 format('(F',i2,'.',i2,')')
|
|
else
|
|
write(fomat(k),6000) i1vs(k),i2vs(k)
|
|
6000 format('(F',i2,'.',i1,')')
|
|
endif
|
|
else
|
|
if(i1vs(k) .lt. 0) then
|
|
itemp= i1vs(k)+256
|
|
write(fomat(k),60011) itemp
|
|
60011 format('(A',i3,')')
|
|
|
|
elseif(i1vs (k) .lt. 10) then
|
|
write(fomat(k),6001) i1vs(k)
|
|
6001 format('(A',i1,')')
|
|
else
|
|
write(fomat(k),6002) i1vs(k)
|
|
6002 format('(A',i2,')')
|
|
endif
|
|
endif
|
|
nfl=nfl+i1vs(k)
|
|
enddo
|
|
read(114) a32
|
|
call choosrec(label,nrecsh,nchs)
|
|
|
|
|
|
230 continue
|
|
JK=0
|
|
JL=0
|
|
if(i9 .eq. 1) then
|
|
do JJ=1,200000
|
|
read(113,end=300) ai7,ai8
|
|
CALL BTOL(AI7,IA7)
|
|
CALL BTOL(AI8,IA8)
|
|
READ(113) I1,FP1,FP2
|
|
CMAP(JJ,1)=FP1
|
|
CMAP(JJ,2)=FP2
|
|
XMAP(JJ)=FP1
|
|
YMAP(JJ)=FP2
|
|
MAXPTS=JJ
|
|
JLINT=JJ
|
|
KLINT=1
|
|
c VAL(JJ)=-2.
|
|
ENDDO
|
|
300 CONTINUE
|
|
MAXPTS=MAXPTS+1
|
|
XMAP(MAXPTS)= VOID
|
|
JLINT=MAXPTS
|
|
LINTYP(1)=2
|
|
|
|
!
|
|
!c finished shape file now read dbf stat with header
|
|
!
|
|
! read(114) i1,i2,i1s,i2s,i3,i4,i5,i6,i7
|
|
! nrecs=i2
|
|
! nbytesh=i1s
|
|
! nrecsh=nbytesh/32-1
|
|
! ndytesrec=i2s
|
|
! nfl=0
|
|
!
|
|
!c now process labels
|
|
!
|
|
! do k=1,nrecsh
|
|
! read(114) label(k),type(k),i3,i1vs(k),i2vs(k),i3s,i4,i5,i6
|
|
! if(type(k) .eq. 'F' .or. type(k) .eq. 'N') then
|
|
! write(fomat(k),6000) i1vs(k),i2vs(k)
|
|
! 6000 format('(F',i2,'.',i1,')')
|
|
! else
|
|
! if(i1vs (k) .lt. 10) then
|
|
! write(fomat(k),6001) i1vs(k)
|
|
! 6001 format('(A',i1,')')
|
|
! else
|
|
! write(fomat(k),6002) i1vs(k)
|
|
! 6002 format('(A',i2,')')
|
|
! endif
|
|
! endif
|
|
! nfl=nfl+i1vs(k)
|
|
! enddo
|
|
!read(114) a3
|
|
!call choosrec(label,nrecsh,nchs)
|
|
do j=1,nrecs
|
|
do k=1,nrecsh
|
|
if(i1vs(k) .lt. 0) then
|
|
itemp=i1vs(k)+256
|
|
else
|
|
itemp=i1vs(k)
|
|
endif
|
|
read(114) field(1:itemp)
|
|
read(field,fomat(k)) vtemp(k)
|
|
enddo
|
|
val(j)=vtemp(NCHS)
|
|
read(114) a3
|
|
enddo
|
|
else
|
|
|
|
do JJ=1,200000
|
|
read(113,end=500) ai7,ai8
|
|
CALL BTOL(AI7,IA7)
|
|
CALL BTOL(AI8,IA8)
|
|
read(113) istp,FP1,FP2,FP3,FP4,npart,npts,nd1
|
|
! do j=1,nrecs
|
|
ierrrd=0
|
|
do k=1,nrecsh
|
|
read(114) field(1:i1vs(k))
|
|
read(field,fomat(k),err=450) vtemp(k)
|
|
cycle
|
|
450 write(90,*)'error reading bed level value set = 0., data = '
|
|
+ ,field(1:i1vs(k))
|
|
ierrrd=1
|
|
enddo
|
|
if(ierrrd .eq. 1)
|
|
+ CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK
|
|
+ ,'Errors reading bed level','BED LEVEL SET = 0.0')
|
|
read(114) a3
|
|
! enddo
|
|
JL=JL+1
|
|
IF(IASK .EQ. 1) THEN
|
|
LINTYP(JL)=LINTYP(JL-1)
|
|
GO TO 440
|
|
ENDIF
|
|
CALL WMessageBox(YesNo, QuestionIcon, 1,
|
|
+ 'Is this an outline map?','MAP-OUTLINE')
|
|
|
|
! If answer 'Yes' set igtwel to 0
|
|
!
|
|
IF (WInfoDialog(4) .EQ. 2) then
|
|
!NO
|
|
LINTYP(JL)=1
|
|
ELSE
|
|
!YES
|
|
LINTYP(JL)=0
|
|
ENDIF
|
|
CALL WMessageBox(YesNo, QuestionIcon, 1,
|
|
+ 'Ask this question again?','GET LINE TYPE AGAIN')
|
|
|
|
! If answer 'Yes' set igtwel to 0
|
|
!
|
|
IF (WInfoDialog(4) .EQ. 2) then
|
|
!NO
|
|
IASK=1
|
|
ELSE
|
|
!YES
|
|
IASK=0
|
|
ENDIF
|
|
440 CONTINUE
|
|
do k=1,npts
|
|
read(113) fp1,fp2
|
|
WRITE(155,*) JK,JL,FP1,FP2,VTEMP(NCHS)
|
|
jk=jk+1
|
|
CMAP(jk,1)=FP1
|
|
CMAP(jk,2)=FP2
|
|
XMAP(jk)=FP1
|
|
YMAP(jk)=FP2
|
|
MAXPTS=jk
|
|
val(jK)=vtemp(NCHS)
|
|
|
|
enddo
|
|
jk=jk+1
|
|
CMAP(jk,1)=-1.e10
|
|
CMAP(jk,2)=-1.e10
|
|
XMAP(jk)=-1.e10
|
|
YMAP(jk)=-1.e10
|
|
MAXPTS=jk
|
|
val(jK)=0.
|
|
enddo
|
|
500 continue
|
|
MAXPTS=JK
|
|
KLINT=JL
|
|
JLINT=MAXPTS
|
|
endif
|
|
c write(157,8888) klint,jlint,(j,xmap(j),ymap(j),val(j),j=1,jlint)
|
|
c write(157,8887)
|
|
c 1 ,(k,lintyp(k),k=1,klint)
|
|
c8888 format('start',2i5/(i6,3e15.6))
|
|
c8887 format('lin'/(2i8))
|
|
|
|
600 CONTINUE
|
|
CLOSE (113)
|
|
RETURN
|
|
END
|
|
|
|
|
|
SUBROUTINE BTOL(AICHG,ICHG)
|
|
INTEGER ICHG,ITEMP
|
|
CHARACTER*4 AICHG,AAICHG
|
|
EQUIVALENCE(ITEMP,AAICHG)
|
|
aaICHG(1:1)=aICHG(4:4)
|
|
aaICHG(2:2)=aICHG(3:3)
|
|
aaICHG(3:3)=aICHG(2:2)
|
|
aaICHG(4:4)=aICHG(1:1)
|
|
ICHG=ITEMP
|
|
RETURN
|
|
END
|
|
|
|
subroutine choosrec(label,nrecsh,nchs)
|
|
use winteracter
|
|
implicit none
|
|
include 'D.inc'
|
|
SAVE
|
|
character*11 label(*)
|
|
INTEGER NRECSH,NCHS,IERR,N,icbox
|
|
|
|
|
|
!
|
|
! Declare window-type and message variables
|
|
!
|
|
TYPE(WIN_STYLE) :: WINDOW
|
|
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
|
|
|
call wdialogload(IDD_CHSTYP)
|
|
ierr=infoerror(1)
|
|
call wdialogputcheckBox(idf_check1,icbox)
|
|
|
|
do n=1,NRECSH
|
|
write(90,'(a)') 'file',n,LABEL(N)
|
|
CALL WDialogPutString(idf_string25+n-1,LABEL(n))
|
|
call wdialogputradiobutton(idf_radio1)
|
|
enddo
|
|
CALL WDialogSelect(IDD_CHSTYP)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
|
ierr=infoerror(1)
|
|
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
|
call wdialogGetradiobutton(idf_radio1,NCHS)
|
|
call wdialogGetcheckBox(idf_check1,icbox)
|
|
ENDIF
|
|
if(icbox .eq. 1) nchs=0
|
|
RETURN
|
|
END
|
|
|
|
|
|
|
|
|