RMAGEN84/SRC84/RDOUTLIN.F90

      MODULE BLKOUT
      ALLOCATABLE XOUTL(:),YOUTL(:)
      INTEGER NOUTLIN
      ENDMODULE
    
      SUBROUTINE RDOUTLIN
!
!   ROUTINE TO READ COORDINATES OF MESH OUTLINE    
    
      USE WINTERACTER
      USE BLKOUT
      USE BLK1MOD
      USE BLKMAP
      INCLUDE 'BFILES.I90'
      include 'TXFRM.COM'

      CHARACTER(LEN=255)  :: FNAME
!      CHARACTER(LEN=3)    :: SUB,SUB1
      CHARACTER(LEN=256)  :: FILTER
      CHARACTER*3 SUB
      
      FILTER ="Outline files -- *.txt,*.map,*.shp|*.txt;*.map;*.shp|txt files -- |*.txt|map files -- |*.map|Polygon shapefiles - *.shp|*.shp|All files -- |*.*|"      
      CALL WSelectFile(FILTER,PromptOn,FNAME,'Load Outline File')

      IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN

         CALL IlowerCase(FNAME)
         CALL GETSUB(FNAME,SUB)

         IF(SUB .EQ. 'map') then
           KTYP=2
           OPEN(99,FILE=FNAME,STATUS='OLD')
         ELSEIF(SUB .EQ. 'txt') then
           KTYP=1
           OPEN(99,FILE=FNAME,STATUS='OLD')
         ELSE
           KTYP=3
           OPEN(99,FILE=FNAME,STATUS='OLD',form='binary')
         ENDIF
      ELSE
        RETURN
      ENDIF

      IF(KTYP .EQ. 3) THEN
        CALL RDSHP5(99)
      ELSE    
        ALLOCATE (XOUTL(5000),YOUTL(5000))
        IF(KTYP .EQ. 2) READ(99,*) INDM
        DO N=1,5000
          READ(99,*,END=500,ERR=500) XOUTL(N),YOUTL(N)
        ENDDO
      ENDIF  
!  Find max and min

      !XMIN = 1.E+20
      !XMAX = -XMIN
      !YMIN = 1.E+20
      !YMAX = -YMIN
      !
      !DO J=1,MAXPTS
      !  IF (CMAP(J,1) .LT. VDX)  CYCLE
      !  IF (CMAP(J,1) .LT. XMIN)  XMIN = CMAP(J,1)
      !  IF (CMAP(J,1) .GT. XMAX)  XMAX = CMAP(J,1)
      !  IF (CMAP(J,2) .LT. YMIN)  YMIN = CMAP(J,2)
      !  IF (CMAP(J,2) .GT. YMAX)  YMAX = CMAP(J,2)
      !ENDDO
      !AMAP=(XMAX-XMIN)*(YMAX-YMIN)
      !XSCALE = (XMAX-XMIN)/(hsize-0.5)
      !YSCALE = (YMAX-YMIN)/6.5
      !PSCALE = MAX(XSCALE,YSCALE)
      !
      !XAVE = (XMIN + XMAX) /2.0
      !YAVE = (YMIN + YMAX) /2.0
      !XMIN = XAVE - hsize/2.*PSCALE
      !YMIN = YAVE - 3.5*PSCALE
      !XMAX = XAVE + (hsize-0.5)/2.*PSCALE
      !YMAX = YAVE + 3.25*PSCALE
      IMP=99
      close(99)
500   CONTINUE
      NOUTLIN=N-1
      RETURN
    END
    
    
    
    
    SUBROUTINE RDSHP5(IMP1)
    use blkmap
    USE BLK1MOD
    include 'TXFRM.COM'
    
    INTEGER STATUS,I1,I2,I3,I4,I5,I6,I7,I8,I9,NREC,NARS,ISTYP,J2,J3,J4,IADB(1000)
    integer*2 i1s,i2s,i3s,i3vs(20)
    integer*1 i1vs(20),i2vs(20),i1s1,i1s2,i2s1,i2s2
    character*1 type(20),a2,a3,a4
    character*4 ai1s,ai2s
    character*11 label(20),fomat(20)
    character*256 field
    character*2 a32

    REAL*8 AXMN,AYMN,AXMX,AYMX,FZ,BXMN,BYMN,BXMX,BYMX,vtemp(20)
    DATA IFIRST/0/
    
!    process dbf file for labels    
    
      IASK=0
      read(114) i1,i2,i1s1,i1s2,i2s1,i2s2,i3,i4,i5,i6,i7
      
!        limited to small lengths
      
      nrecs=i2
      nbytesh=i1s1
      nrecsh=nbytesh/32-1
      ndytesrec=i2s1
      nfl=0

!     now process labels
      do k=1,nrecsh
        read(114) label(k),type(k),i3,i1vs(k),i2vs(k),i3s,i4,i5,i6
        if(k .eq. 1) i3vs(k)=1
        i3vs(k+1)=i3vs(k)+i1vs(k)
        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  
      enddo
      read(114) a32
      call choosrec(label,nrecsh,nchs)
      ierrrd=0
      do k=1,nrecs
        if(nchs .eq. 0) then
          vtemp(k)=-9999.0
          cycle
        endif
        read(114) field(1:ndytesrec)
        l1=i3vs(nchs)
        l2=i3vs(nchs+1)
        read(field(l1:l2),fomat(nchs),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

    
    IF(IFIRST .GT. 0) THEN
      IS=MAXPTS-1
      IP=KLINT+1
    ELSE
1     IS=0
      IP=2
    ENDIF

    READ(IMP1) I1,I2,I3,I4,I5,I6,I7,I8,I9,AXMN,AYMN,AXMX,AYMX,FZ,FZ,FZ,FZ
100 READ(IMP1,END=200) NREC,NARS
!    NREC  = RECORD NUMBER
!    NARS  = RECORD LENGTH
    READ(IMP1) ISTYP,BXMN,BYMN,BXMX,BYMX,J2,J3
!    J2  = NUMBER OF PARTS
!    J3  = NUMBER OF POINTS
    READ(IMP1) (IADB(I),I=1,J2)
    IF( .NOT. ALLOCATED(CMAP)) THEN
      MAXPL=J3
      ALLOCATE (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL))
    ENDIF
    LINTYP(IP-1)=0
    DO I=1,J3
      !IF(IADB(IP) .GT. 0) THEN
      !  IF(I .GT. IADB(IP)) THEN
      !    IS=IS+1
      !    XMAP(IS)=VOID
      !    YMAP(IS)=VOID
      !    CMAP(IS,1)=VOID
      !    CMAP(IS,2)=VOID
      !    VAL(IS)=VOID
      !    IP=IP+1
      !    LINTYP(IP-1)=0
      !  ENDIF
      !ENDIF  
      IS=IS+1    
      READ(IMP1) CMAP(IS,1),CMAP(IS,2)
      XMAP(IS)=CMAP(IS,1)
      YMAP(IS)=CMAP(IS,2)
      CMAP(IS,1) = (CMAP(IS,1) + XS) /TXSCAL
      CMAP(IS,2) = (CMAP(IS,2) + YS) /TXSCAL
      VAL(IS)=-9999.
      VAL(IS)=VTEMP(IP-1)
    ENDDO
    IS=IS+1
    XMAP(IS)=VOID
    YMAP(IS)=VOID
    CMAP(IS,1)=VOID
    CMAP(IS,2)=VOID
    VAL(IS)=VOID
    IP=IP+1
    LINTYP(IP-1)=0
    MAXPTS=IS+1
    XMAP(MAXPTS)= VOID         
    JLINT=MAXPTS
    KLINT=IP
    GO TO 100
200 CONTINUE
    IFIRST=1
    
    
    RETURN
    END