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 ! ! 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