RMAGEN84/SRC84/READSHP.FOR

      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