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.
293 lines
7.5 KiB
Fortran
293 lines
7.5 KiB
Fortran
5 years ago
|
SUBROUTINE FILLTR
|
||
|
|
USE WINTERACTER
|
||
|
|
USE IFPORT
|
||
|
|
USE BLKMAP
|
||
|
|
CHARACTER(LEN=256) :: FILTER,FNAME
|
||
|
|
CHARACTER(LEN=80) :: DATAIN,OPTIONS
|
||
|
|
CHARACTER(LEN=96) :: LOCDIR
|
||
|
|
CHARACTER(LEN=3) :: SUB
|
||
|
|
INTEGER INOUTL,NOUTL,OUTPOL
|
||
|
|
INTEGER NTRIAN(5000,2),TWO,ZERO,ntrans(5000)
|
||
|
|
INTEGER*2 RESULT
|
||
|
|
LOGICAL EXISTS
|
||
|
|
do k=1,80
|
||
|
|
options(k:k)=' '
|
||
|
|
enddo
|
||
|
|
TWO=2
|
||
|
|
ZERO=0
|
||
|
|
INOUTL=22
|
||
|
|
OUTPOL=23
|
||
|
|
VOID = - 1.0E+10
|
||
|
|
VDX = - 1.0E+9
|
||
|
|
|
||
|
|
!
|
||
|
|
! get filename
|
||
|
|
|
||
|
|
! FILTER ="Data files|*.dat;*.txt;*.map|Map file -- *.map|*.map|"
|
||
|
|
! CALL WSelectFile(FILTER,PromptOn+DirChange+Appendext,FNAME,'Load data file')
|
||
|
|
|
||
|
|
! IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||
|
|
! OPEN(INOUTL,FILE=FNAME,STATUS='OLD')
|
||
|
|
! CALL IlowerCase(FNAME)
|
||
|
|
! CALL GETSUB(FNAME,SUB)
|
||
|
|
! IF(SUB .EQ. 'map') then
|
||
|
|
! IMAPIN=1
|
||
|
|
! ELSE
|
||
|
|
! IMAPIN=0
|
||
|
|
! ENDIF
|
||
|
|
! ELSE
|
||
|
|
! WRITE(*,*) 'ERROR NO FILE'
|
||
|
|
! ENDIF
|
||
|
|
IMAPIN=1
|
||
|
|
! read outline
|
||
|
|
!
|
||
|
|
IF(IMAPIN .EQ. 1) THEN
|
||
|
|
OPEN(113,FORM='BINARY',STATUS='SCRATCH')
|
||
|
|
WRITE(113) XMAP,YMAP
|
||
|
|
REWIND (113)
|
||
|
|
DO K=1,5000
|
||
|
|
IF(XMAP(K) .LT. VDX) THEN
|
||
|
|
NOUTL=K-1
|
||
|
|
GO TO 90
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
90 CONTINUE
|
||
|
|
ELSE
|
||
|
|
! IF(IMAPIN .EQ. 1) READ(INOUTL,'(A80)') DATAIN
|
||
|
|
DO K=1,5000
|
||
|
|
READ(INOUTL,'(A80)') DATAIN
|
||
|
|
IF(DATAIN(1:3) .EQ. 'END' .OR. DATAIN(1:3) .EQ. 'end') then
|
||
|
|
NOUTL=K-1
|
||
|
|
GO TO 100
|
||
|
|
ELSE
|
||
|
|
READ(DATAIN,*) XMAP(K),YMAP(K)
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
100 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
IF(XMAP(NOUTL) .EQ. XMAP(1) .AND. YMAP(NOUTL) .EQ. YMAP(1)) THEN
|
||
|
|
XMAP(NOUTL)=VOID
|
||
|
|
YMAP(NOUTL)=VOID
|
||
|
|
NOUTL=NOUTL-1
|
||
|
|
LOOPC=1
|
||
|
|
ELSE
|
||
|
|
LOOPC=0
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
DO J=1, NOUTL
|
||
|
|
NTRIAN(J,1)=J
|
||
|
|
NTRIAN(J,2)=J+1
|
||
|
|
ENDDO
|
||
|
|
NTRIAN(NOUTL,2)=1
|
||
|
|
JC=NOUTL
|
||
|
|
! read contours
|
||
|
|
NOUTBE=NOUTL+1
|
||
|
|
NOUTT=NOUTL
|
||
|
|
DO N=1,100
|
||
|
|
if(imapin .eq. 1) then
|
||
|
|
noutb=noutt+2+LOOPC
|
||
|
|
ncnt=0
|
||
|
|
DO K=NOUTB,5000
|
||
|
|
if(k .eq. noutb) then
|
||
|
|
if(xmap(k) .lt. vdx) go to 300
|
||
|
|
endif
|
||
|
|
IF(XMAP(K) .LT. VDX) THEN
|
||
|
|
NOUTT=K-1
|
||
|
|
GO TO 110
|
||
|
|
ENDIF
|
||
|
|
ncnt=ncnt+1
|
||
|
|
ENDDO
|
||
|
|
110 CONTINUE
|
||
|
|
else
|
||
|
|
READ(INOUTL,'(A80)', END=300) DATAIN
|
||
|
|
IF(DATAIN(1:3) .EQ. 'END') GO TO 300
|
||
|
|
NOUTB=NOUTT+1
|
||
|
|
NCNT=0
|
||
|
|
DO K=NOUTB,5000
|
||
|
|
READ(INOUTL,'(A80)') DATAIN
|
||
|
|
IF(DATAIN(1:3) .EQ. 'END' .OR. DATAIN(1:3) .EQ. 'end') then
|
||
|
|
NOUTT=K-1
|
||
|
|
GO TO 200
|
||
|
|
ELSE
|
||
|
|
READ(DATAIN,*) XMAP(K),YMAP(K)
|
||
|
|
NCNT=NCNT+1
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
200 CONTINUE
|
||
|
|
endif
|
||
|
|
IF(XMAP(NOUTT) .EQ. XMAP(NOUTB) .AND. YMAP(NOUTT) .EQ. YMAP(NOUTB)) THEN
|
||
|
|
XMAP(NOUTT)=VOID
|
||
|
|
YMAP(NOUTT)=VOID
|
||
|
|
NOUTT=NOUTT-1
|
||
|
|
LOOPC=1
|
||
|
|
ELSE
|
||
|
|
LOOPC=0
|
||
|
|
ENDIF
|
||
|
|
JC=NOUTB-1
|
||
|
|
JCB=JC+1
|
||
|
|
DO J=NOUTBE, NOUTBE+NCNT-2-LOOPC
|
||
|
|
JC=JC+1
|
||
|
|
NTRIAN(J,1)=JC
|
||
|
|
NTRIAN(J,2)=JC+1
|
||
|
|
ENDDO
|
||
|
|
IF(LOOPC .EQ. 1) THEN
|
||
|
|
NTRIAN(NOUTBE+NCNT-2,1)=JC+1
|
||
|
|
NTRIAN(NOUTBE+NCNT-2,2)=JCB
|
||
|
|
NOUTBE=NOUTBE+NCNT-1
|
||
|
|
ELSE
|
||
|
|
NOUTBE=NOUTBE+NCNT-1
|
||
|
|
ENDIF
|
||
|
|
JC=JC+1
|
||
|
|
ENDDO
|
||
|
|
! copy to a file
|
||
|
|
300 CONTINUE
|
||
|
|
OPEN(OUTPOL,FILE='TEST.POLY', STATUS='UNKNOWN')
|
||
|
|
ncnt=0
|
||
|
|
DO K=1,NOUTT
|
||
|
|
if(xmap(k) .lt. vdx) cycle
|
||
|
|
ncnt=ncnt+1
|
||
|
|
ntrans(k)=ncnt
|
||
|
|
ENDDO
|
||
|
|
WRITE(OUTPOL,*) NCNT,TWO,ZERO,ZERO
|
||
|
|
ncnt=0
|
||
|
|
DO K=1,noutt
|
||
|
|
if(xmap(k) .lt. vdx) cycle
|
||
|
|
ncnt=ncnt+1
|
||
|
|
WRITE(OUTPOL,*) ncnt,XMAP(K),YMAP(K)
|
||
|
|
ENDDO
|
||
|
|
WRITE(OUTPOL,*) NOUTBE-1,ZERO
|
||
|
|
DO J=1, NOUTBE-1
|
||
|
|
WRITE(OUTPOL,*) J,ntrans(NTRIAN(J,1)),ntrans(NTRIAN(J,2))
|
||
|
|
ENDDO
|
||
|
|
WRITE(OUTPOL,*) ZERO
|
||
|
|
FLUSH (OUTPOL)
|
||
|
|
REWIND (OUTPOL)
|
||
|
|
CLOSE (OUTPOL)
|
||
|
|
! close (inoutl)
|
||
|
|
! setup options
|
||
|
|
|
||
|
|
! OPTIONS = ' -pqa5000V TEST'
|
||
|
|
OPTIONS(1:3) = ' -p'
|
||
|
|
nct=3
|
||
|
|
iswq=1
|
||
|
|
iswy=0
|
||
|
|
id1=100
|
||
|
|
CALL PANELFILLT(ISWQ,ISWY,ID1)
|
||
|
|
|
||
|
|
IF(ISWQ .EQ. 1) THEN
|
||
|
|
NCT=NCT+1
|
||
|
|
OPTIONS(NCT:NCT)='q'
|
||
|
|
ENDIF
|
||
|
|
IF(ISWY .EQ. 1) THEN
|
||
|
|
NCT=NCT+1
|
||
|
|
OPTIONS(NCT:NCT)='q'
|
||
|
|
ENDIF
|
||
|
|
ID1=ID1**2/2
|
||
|
|
WRITE(OPTIONS(NCT+1:NCT+12),'(''a'',I6.6,'' TEST'')') ID1
|
||
|
|
! go to TRIANGLE
|
||
|
|
|
||
|
|
INQUIRE (FILE = 'test.1.ele', EXIST = exists)
|
||
|
|
if(exists) then
|
||
|
|
open(77,file= 'test.1.ele')
|
||
|
|
close(77,status='DELETE')
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
INQUIRE (FILE = 'test.1.node', EXIST = exists)
|
||
|
|
if(exists) then
|
||
|
|
open(77,file= 'test.1.node')
|
||
|
|
close(77,status='DELETE')
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
INQUIRE (FILE = 'test.1.poly', EXIST = exists)
|
||
|
|
if(exists) then
|
||
|
|
open(77,file= 'test.1.poly')
|
||
|
|
close(77,status='DELETE')
|
||
|
|
ENDIF
|
||
|
|
INQUIRE (FILE = "C:\Program Files\RMA\TRIANGLE.EXE", EXIST = exists)
|
||
|
|
if(.not. exists) then
|
||
|
|
INQUIRE (FILE = "TRIANGLE.EXE", EXIST = exists)
|
||
|
|
if(.not. exists) then
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'TRIANGLE is not available in '//CHAR(13)//&
|
||
|
|
'C:\Program Files\RMA\ directory'//CHAR(13)//'Do you wish to define directory?'&
|
||
|
|
,'WARNING TRIANGLE IS NOT AVAILABLE')
|
||
|
|
|
||
|
|
! If answer 'No', return
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(4).EQ.2) return
|
||
|
|
CALL GETDIR(LOCDIR)
|
||
|
|
else
|
||
|
|
LOCDIR(1:8)='TRIANGLE'
|
||
|
|
! WRITE(155,*) LOCDIR
|
||
|
|
RESULT= RUNQQ(LOCDIR, OPTIONS)
|
||
|
|
GO TO 600
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
|
||
|
|
RESULT= RUNQQ("C:\Program Files\RMA\TRIANGLE", OPTIONS)
|
||
|
|
! RESULT= RUNQQ("TRIANGLE", OPTIONS)
|
||
|
|
600 CONTINUE
|
||
|
|
IF(IMAPIN .EQ. 1) THEN
|
||
|
|
READ(113) XMAP,YMAP
|
||
|
|
CLOSE (113)
|
||
|
|
ENDIF
|
||
|
|
IIN=10
|
||
|
|
OPEN(IIN,FILE='TEST.1.ELE', STATUS='OLD')
|
||
|
|
|
||
|
|
CALL GETNEWFIL(IIN,0,1,1)
|
||
|
|
|
||
|
|
|
||
|
|
! finish up
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE PANELFILLT(N1,N2,N3)
|
||
|
|
|
||
|
|
use winteracter
|
||
|
|
implicit none
|
||
|
|
SAVE
|
||
|
|
|
||
|
|
include 'D.inc'
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
integer :: N1,N2,N3,IERR,ITIME
|
||
|
|
! real ::
|
||
|
|
! character*3 ::
|
||
|
|
DATA ITIME/0/
|
||
|
|
! IF(ITIME .EQ. 0) THEN
|
||
|
|
! ITIME=1
|
||
|
|
! N1=1
|
||
|
|
! N2=0
|
||
|
|
! N3=100
|
||
|
|
! ENDIF
|
||
|
|
|
||
|
|
call wdialogload(IDD_FTRIAN)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutCheckBox(idf_check1,n1)
|
||
|
|
CALL WDialogPutCheckBox(idf_check2,n2)
|
||
|
|
CALL WDialogPutInteger(idf_integer1,n3)
|
||
|
|
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_FTRIAN)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
CALL WDialogGetCheckBox(idf_check1,n1)
|
||
|
|
CALL WDialogGetCheckBox(idf_check2,n2)
|
||
|
|
CALL WDialogGetInteger(idf_integer1,n3)
|
||
|
|
ELSEIF(WInfoDialog(ExitButton) .EQ. IDCANCEL) THEN
|
||
|
|
N3=-1
|
||
|
|
ENDIF
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|