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.
226 lines
5.5 KiB
Plaintext
226 lines
5.5 KiB
Plaintext
5 years ago
|
SUBROUTINE READSHP
|
||
|
|
|
||
|
|
USE BLKMAP
|
||
|
|
USE BLK1MOD
|
||
|
|
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
|
||
|
|
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
|
||
|
|
|
||
|
|
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
|
||
|
|
c VAL(JJ)=-2.
|
||
|
|
ENDDO
|
||
|
|
300 CONTINUE
|
||
|
|
XMAP(MAXPTS+1)= VOID
|
||
|
|
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
|
||
|
|
do k=1,nrecsh
|
||
|
|
read(114) field(1:i1vs(k))
|
||
|
|
read(field,fomat(k)) vtemp(k)
|
||
|
|
enddo
|
||
|
|
read(114) a3
|
||
|
|
! enddo
|
||
|
|
JL=JL+1
|
||
|
|
LINTYP(JL)=1
|
||
|
|
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-1
|
||
|
|
KLINT=JL
|
||
|
|
JLINT=MAXPTS
|
||
|
|
endif
|
||
|
|
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
|
||
|
|
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
call wdialogload(IDD_CHSTYP)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
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)
|
||
|
|
ENDIF
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|