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