You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
128 lines
2.9 KiB
Fortran
128 lines
2.9 KiB
Fortran
5 years ago
|
SUBROUTINE GOUTLIN
|
||
|
|
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
|
||
|
|
CHARACTER(LEN=255) :: FNAME,FILTER
|
||
|
|
CHARACTER(LEN=4) :: SUB
|
||
|
|
LOGICAL OPENED
|
||
|
|
CHARACTER*1 IFLAG,ANS(10)
|
||
|
|
! DIMENSION XOUT(1000),YOUT(1000)
|
||
|
|
DATA ANS/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||
|
|
|
||
|
|
IF(.NOT. ALLOCATED(XOUT)) THEN
|
||
|
|
ALLOCATE (XOUT(5000,10),YOUT(5000,10))
|
||
|
|
ENDIF
|
||
|
|
N=0
|
||
|
|
IOUTOUT=25
|
||
|
|
INQUIRE(25, OPENED=OPENED)
|
||
|
|
if(.not. opened) then
|
||
|
|
Filter='OUTLINE file -- *.dat|*.dat|POLY file -- *.poly|*.poly|'
|
||
|
|
|
||
|
|
CALL WSelectFile(Filter,SaveDialog+PromptOn+AppendExt+DirChange,FNAME,'Save Outline File')
|
||
|
|
|
||
|
|
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||
|
|
|
||
|
|
CALL IlowerCase(FNAME)
|
||
|
|
CALL GETSUB(FNAME,SUB)
|
||
|
|
OPEN(IOUTOUT,FILE=FNAME,STATUS='UNKNOWN',ACTION='WRITE')
|
||
|
|
ELSE
|
||
|
|
GO TO 1
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
1 CONTINUE
|
||
|
|
|
||
|
|
IF(SUB(1:3) .EQ. 'dat') THEN
|
||
|
|
IOUTSW=0
|
||
|
|
ELSE
|
||
|
|
IOUTSW=1
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
!IPK GET STRING OF MAP COORDINATES
|
||
|
|
|
||
|
|
!
|
||
|
|
! Draw box around selections
|
||
|
|
!
|
||
|
|
2 CONTINUE
|
||
|
|
|
||
|
|
NHTPSV=NHTP
|
||
|
|
NMESSV=NMESS
|
||
|
|
NBRRSV=NBRR
|
||
|
|
|
||
|
|
NHTP=0
|
||
|
|
NBRR=1
|
||
|
|
NMESS=45
|
||
|
|
CALL HEDR
|
||
|
|
!
|
||
|
|
! Get answer
|
||
|
|
!
|
||
|
|
! 3 call xyloc(XPT,YPT,ANS,IBOX)
|
||
|
|
3 call xyloc(XPT,YPT,IFLAG,IBOX)
|
||
|
|
!
|
||
|
|
IF(IRMAIN .NE. 1 .and. ibox .ne. 10) THEN
|
||
|
|
|
||
|
|
N=N+1
|
||
|
|
XTMP = XPT*TXSCAL - XS
|
||
|
|
YTMP = YPT*TXSCAL - YS
|
||
|
|
IF(IOUTSW .EQ. 0) THEN
|
||
|
|
WRITE(IOUTOUT,*) XTMP,YTMP
|
||
|
|
ELSE
|
||
|
|
XOUT(N,1)=XTMP
|
||
|
|
YOUT(N,1)=YTMP
|
||
|
|
ENDIF
|
||
|
|
GO TO 3
|
||
|
|
|
||
|
|
ENDIF
|
||
|
|
IF(IOUTSW .EQ. 1) THEN
|
||
|
|
NDIM=2
|
||
|
|
NZERO=0
|
||
|
|
NONE=1
|
||
|
|
WRITE(IOUTOUT,*)N,NDIM,NZERO,NZERO
|
||
|
|
DO I=1,N
|
||
|
|
WRITE(IOUTOUT,*) I,XOUT(I,1),YOUT(I,1)
|
||
|
|
ENDDO
|
||
|
|
WRITE(IOUTOUT,*) N,NZERO
|
||
|
|
DO I=1,N-1
|
||
|
|
WRITE(IOUTOUT,*) I,I,I+1
|
||
|
|
ENDDO
|
||
|
|
WRITE(IOUTOUT,*) N,N,NONE
|
||
|
|
|
||
|
|
WRITE(IOUTOUT,*) NZERO
|
||
|
|
ENDIF
|
||
|
|
NHTP=NHTPSV
|
||
|
|
NMESS=NMESSV
|
||
|
|
NBRR=NBRRSV
|
||
|
|
CALL HEDR
|
||
|
|
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE GETSUB4(FNAME,SUB)
|
||
|
|
CHARACTER(LEN=255) :: FNAME
|
||
|
|
CHARACTER(LEN=4) :: SUB
|
||
|
|
INTEGER ,EXTERNAL :: LENSTR
|
||
|
|
INTEGER :: LNNAM,K
|
||
|
|
|
||
|
|
LNNAM=LENSTR(FNAME)
|
||
|
|
SUB=' '
|
||
|
|
DO K=LNNAM,1,-1
|
||
|
|
IF(FNAME(K:K) .EQ. '.') THEN
|
||
|
|
IF(LNNAM .GT. K+3) THEN
|
||
|
|
SUB=FNAME(K+1:K+4)
|
||
|
|
ELSEIF(LNNAM .GT. K+2) THEN
|
||
|
|
SUB(1:3)=FNAME(K+1:K+3)
|
||
|
|
SUB(4:4)=' '
|
||
|
|
ELSE
|
||
|
|
SUB=' '
|
||
|
|
ENDIF
|
||
|
|
GO TO 110
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
110 CONTINUE
|
||
|
|
RETURN
|
||
|
|
END
|