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.
307 lines
7.8 KiB
Fortran
307 lines
7.8 KiB
Fortran
8 years ago
|
SUBROUTINE ADDMESHT
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
USE WINTERACTER
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
|
||
|
|
INTEGER OUTPOL,TWO,ZERO,IFILOUT
|
||
|
|
INTEGER NTRIAN(5000,2),ICT
|
||
|
|
REAL XMAP1(5000),YMAP1(5000)
|
||
|
|
|
||
|
|
CHARACTER*1 ANSW(10),ANS
|
||
|
|
CHARACTER(LEN=80) :: DATAIN,OPTIONS
|
||
|
|
CHARACTER(LEN=96) :: LOCDIR
|
||
|
|
LOGICAL EXISTS
|
||
|
|
DATA ANSW/' ',' ',' ',' ',' ','b','n','z','r','q'/
|
||
|
|
do k=1,80
|
||
|
|
options(k:k)=' '
|
||
|
|
enddo
|
||
|
|
TWO=2
|
||
|
|
ZERO=0
|
||
|
|
OUTPOL=23
|
||
|
|
ICT=0
|
||
|
|
! add headers
|
||
|
|
NHTPSV=NHTP
|
||
|
|
NMESSSV=NMESS
|
||
|
|
NBRRSV=NBRR
|
||
|
|
NHTP=0
|
||
|
|
NMESS=48
|
||
|
|
NBRR=5
|
||
|
|
call hedr
|
||
|
|
! go and get points to form outline
|
||
|
|
200 CALL xyloc(XTEMP,YTEMP,ans,IBOX)
|
||
|
|
siz=0.1
|
||
|
|
call drawcr(xtemp,ytemp,siz)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(ANS .EQ. 'c') THEN
|
||
|
|
if(ibox .eq. 0) go to 400
|
||
|
|
I=IBOX
|
||
|
|
ANS=ANSW(I)
|
||
|
|
ENDIF
|
||
|
|
IF(ANS .EQ. 'b') THEN
|
||
|
|
ICT=ICT-1
|
||
|
|
GO TO 200
|
||
|
|
ELSEIF(ANS .EQ. 'n') THEN
|
||
|
|
GO TO 500
|
||
|
|
ELSEIF(ANS .EQ. 'q') THEN
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
400 ICT=ICT+1
|
||
|
|
XMAP1(ICT) = XTEMP*TXSCAL - XS
|
||
|
|
YMAP1(ICT) = YTEMP*TXSCAL - YS
|
||
|
|
IF(ICT .GT. 1) THEN
|
||
|
|
NTRIAN(ICT-1,1)=ICT-1
|
||
|
|
NTRIAN(ICT-1,2)=ICT
|
||
|
|
ENDIF
|
||
|
|
GO TO 200
|
||
|
|
500 CONTINUE
|
||
|
|
NTRIAN(ICT,1)=ICT
|
||
|
|
NTRIAN(ICT,2)=1
|
||
|
|
|
||
|
|
! write current data to a scratch file for later addition
|
||
|
|
IFILOUT=IACTVFIL+50
|
||
|
|
CALL WRTFIL(IFILOUT)
|
||
|
|
!
|
||
|
|
! IF(IACTVFIL .GT. 0) THEN
|
||
|
|
! CALL WRTFIL(50)
|
||
|
|
! IFILOUT=IACTVFIL+50
|
||
|
|
! CALL WRTFIL(IFILOUT)
|
||
|
|
! CALL ZEROOUT
|
||
|
|
! IACTVFIL=ITOTFIL
|
||
|
|
! ELSE
|
||
|
|
! IACTVFIL=1
|
||
|
|
! ENDIF
|
||
|
|
!
|
||
|
|
!! clear screen
|
||
|
|
! CALL clscrn
|
||
|
|
|
||
|
|
! form TRIANG file
|
||
|
|
|
||
|
|
OPEN(OUTPOL,FILE='TEST.POLY', STATUS='UNKNOWN')
|
||
|
|
WRITE(OUTPOL,*) ICT,TWO,ZERO,ZERO
|
||
|
|
DO K=1,ICT
|
||
|
|
WRITE(OUTPOL,*) K,XMAP1(K),YMAP1(K)
|
||
|
|
ENDDO
|
||
|
|
WRITE(OUTPOL,*) ICT,ZERO
|
||
|
|
DO J=1, ICT
|
||
|
|
WRITE(OUTPOL,*) J,ntrian(J,1),ntrian(J,2)
|
||
|
|
ENDDO
|
||
|
|
WRITE(OUTPOL,*) ZERO
|
||
|
|
FLUSH (OUTPOL)
|
||
|
|
REWIND (OUTPOL)
|
||
|
|
CLOSE (OUTPOL)
|
||
|
|
|
||
|
|
! 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 IIN=10
|
||
|
|
OPEN(IIN,FILE='TEST.1.ELE', STATUS='OLD')
|
||
|
|
|
||
|
|
! write(155,*) 'going to get newfile'
|
||
|
|
CALL GETNEWFIL(IIN,0,-1,-1)
|
||
|
|
!IADD=50+iactvfil+1
|
||
|
|
!CALL RDTOCLIP(IADD)
|
||
|
|
!
|
||
|
|
!IF(IADD .EQ. 51) THEN
|
||
|
|
!write(90,*) 'finished addmesh'
|
||
|
|
!
|
||
|
|
!NHTP=NHTPSV
|
||
|
|
!NMESS=NMESSSV
|
||
|
|
!NBRR=NBRRSV
|
||
|
|
!call hedr
|
||
|
|
!ELSE
|
||
|
|
! CALL ADDMESH(0)
|
||
|
|
NHTP=NHTPSV
|
||
|
|
NMESS=NMESSSV
|
||
|
|
NBRR=NBRRSV
|
||
|
|
call hedr
|
||
|
|
CALL PLOTOT(0)
|
||
|
|
|
||
|
|
! CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'Do you wish to delete unused nodes?'//&
|
||
|
|
! CHAR(13)//' ','Delete unused nodes?')
|
||
|
|
! !
|
||
|
|
!! If answer 'No', return
|
||
|
|
!!
|
||
|
|
! IF (WInfoDialog(4).EQ.2) return
|
||
|
|
!!
|
||
|
|
!! Delete all unused nodes
|
||
|
|
!!
|
||
|
|
! CALL DELETM(2)
|
||
|
|
!
|
||
|
|
! ENDIF
|
||
|
|
|
||
|
|
! get new mesh
|
||
|
|
! add meshes together
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE UNDOGEN
|
||
|
|
USE BLK1MOD
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
ALLOCATABLE NODETRAN(:)
|
||
|
|
DATA VDX9/-9.E9/
|
||
|
|
|
||
|
|
! Loop through nodes assigning new number and adding to list
|
||
|
|
|
||
|
|
IF(.NOT. ALLOCATED(NODETRAN)) ALLOCATE (NODETRAN(maxp))
|
||
|
|
|
||
|
|
CALL ZEROOUT
|
||
|
|
IADD=50+IACTVFIL
|
||
|
|
CALL RDTOCLIP(IADD)
|
||
|
|
|
||
|
|
DO N=1,NPSTO(1)
|
||
|
|
IF(XUSRSTO(N,1) .GT. VDX9) THEN
|
||
|
|
CALL GETNOD(J)
|
||
|
|
NODETRAN(N)=J
|
||
|
|
XUSR(J)=XUSRSTO(N,1)
|
||
|
|
YUSR(J)=YUSRSTO(N,1)
|
||
|
|
WD(J)=WDSTO(N,1)
|
||
|
|
WIDTH(J)=WIDTHSTO(N,1)
|
||
|
|
SS1(J)=SS1STO(N,1)
|
||
|
|
SS2(J)=SS2STO(N,1)
|
||
|
|
WIDS(J)=WIDSSTO(N,1)
|
||
|
|
WIDBS(J)=WIDBSSTO(N,1)
|
||
|
|
SSO(J)=SSOSTO(N,1)
|
||
|
|
BS1(J)=BS1STO(N,1)
|
||
|
|
INSKP(J) = 0
|
||
|
|
INEW(J) = 1
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
! Loop through elements assigning new number and adding to list
|
||
|
|
|
||
|
|
DO N=1,NESTO(1)
|
||
|
|
IF(IMATSTO(N,1) .GT. 0) THEN
|
||
|
|
CALL GETELM(M)
|
||
|
|
DO K=1,8
|
||
|
|
IF(NOPSTO(N,K,1) .GT. 0) THEN
|
||
|
|
J=NODETRAN(NOPSTO(N,K,1))
|
||
|
|
NOP(M,K)=J
|
||
|
|
ELSE
|
||
|
|
NOP(M,K)=0
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
IMAT(M)=IMATSTO(N,1)
|
||
|
|
THTA(M)=THTASTO(N,1)
|
||
|
|
IESKP(M)=0
|
||
|
|
NCN = 2
|
||
|
|
IF (NOP(M,3) .NE. 0) NCN = 3
|
||
|
|
IF (NOP(M,4) .NE. 0) NCN = 4
|
||
|
|
IF (NOP(M,5) .NE. 0 .AND. NOP(M,4) .NE. 0) NCN = 5
|
||
|
|
IF (NOP(M,5) .NE. 0 .AND. NOP(M,4) .EQ. 0) NCN = 6
|
||
|
|
IF (NOP(M,6) .NE. 0) NCN = 6
|
||
|
|
IF (NOP(M,7) .NE. 0) NCN = 8
|
||
|
|
NCORN(M) = NCN
|
||
|
|
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
|
||
|
|
! if(iswt .eq. 0) CALL RESCAL
|
||
|
|
CALL RESCAL
|
||
|
|
CALL HEDR
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
SUBROUTINE GETDIR(LOCDIR)
|
||
|
|
use winteracter
|
||
|
|
|
||
|
|
implicit none
|
||
|
|
|
||
|
|
include 'D.inc'
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
CHARACTER*96 LOCDIR
|
||
|
|
integer ierr,K,KL
|
||
|
|
|
||
|
|
call wdialogload(IDD_GETFL)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogPutString(idf_string1,locdir)
|
||
|
|
! LOCDIR='C:\Users\RMA5440\TRIANGLE\TRIANGLE'
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_GETFL)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
do
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
CALL WDialogGetString(idf_string1,locdir)
|
||
|
|
DO K=96,1,-1
|
||
|
|
KL=K
|
||
|
|
IF(LOCDIR(K:K) .NE. ' ') GO TO 200
|
||
|
|
ENDDO
|
||
|
|
LOCDIR(1:8)='TRIANGLE'
|
||
|
|
RETURN
|
||
|
|
200 CONTINUE
|
||
|
|
LOCDIR(KL+1:KL+9)='\TRIANGLE'
|
||
|
|
WRITE(90,*) LOCDIR
|
||
|
|
RETURN
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
END
|