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