RMAGEN84/SRC84/READSHP.FOR

      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