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.
303 lines
8.1 KiB
Fortran
303 lines
8.1 KiB
Fortran
SUBROUTINE OUTLINES(ISWT)
|
|
|
|
USE WINTERACTER
|
|
USE BLK1MOD
|
|
include 'd.inc'
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
! INTEGER*2 MSN
|
|
! COMMON /MID/ MSN(MAXP)
|
|
|
|
CHARACTER(LEN=255) :: FNAME,FILTER
|
|
CHARACTER(LEN=4) :: SUB
|
|
REAL XCEN(10),YCEN(10),MTYP(10)
|
|
LOGICAL OPENED,LSTAT
|
|
CHARACTER*1 IFLAG,ANS(10)
|
|
DATA ANS/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
|
DATA PI2/1.5708/
|
|
IF(.NOT. ALLOCATED(ICONNCT)) THEN
|
|
ALLOCATE (ICONNCT(MAXP,3),IOUTLST(10,5000),NOUTLST(10),NKEP(MAXP))
|
|
ENDIF
|
|
IF(.NOT. ALLOCATED(XOUT)) THEN
|
|
ALLOCATE (XOUT(5000,10),YOUT(5000,10))
|
|
ENDIF
|
|
NOUTLST=0
|
|
IOUTSW=2
|
|
IPOS=2
|
|
IF(ISWT .EQ. 1) GO TO 80
|
|
IOUTOUT=26
|
|
INQUIRE(26, 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
|
|
|
|
call wdialogload(IDD_DIALOG08)
|
|
ierr=infoerror(1)
|
|
|
|
|
|
call wdialogputRadioButton(idf_radio1)
|
|
|
|
|
|
CALL WDialogSelect(IDD_DIALOG08)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
|
ierr=infoerror(1)
|
|
|
|
|
|
do
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
|
|
|
call wdialoggetradiobutton(idf_radio1,ipos)
|
|
ipos=3-ipos
|
|
go to 50
|
|
endif
|
|
ipos= 0
|
|
go to 50
|
|
enddo
|
|
ipos= 2
|
|
50 continue
|
|
IF(SUB(1:3) .EQ. 'dat') THEN
|
|
IOUTSW=0
|
|
ELSE
|
|
IOUTSW=1
|
|
ENDIF
|
|
!
|
|
! FORM LIST OF ELEMENT SIDES THAT ARE ON THE OUTSIDE
|
|
80 CONTINUE
|
|
DO N=1,NP
|
|
MSN(N)=0
|
|
ENDDO
|
|
ILINEL=0
|
|
DO N=1,NE
|
|
IF(IMAT(N) .LE. 0) CYCLE
|
|
IF(IMAT(N) .NE. 999 .AND. NCORN(N) .GT. 5 .AND. (IMAT(N) .LT. 900 .OR. IMAT(N) .GT. 903)) THEN
|
|
NCN=NCORN(N)
|
|
DO K=2,NCN,2
|
|
J = NOP(N,K)
|
|
if(J .gt. 0) then
|
|
MSN(J) = MSN(J) + 1
|
|
ICONNCT(J,3)=N
|
|
ICONNCT(J,1)=NOP(N,K-1)
|
|
IF(K .EQ. NCN) THEN
|
|
ICONNCT(J,2)=NOP(N,1)
|
|
ELSE
|
|
ICONNCT(J,2)=NOP(N,K+1)
|
|
ENDIF
|
|
endif
|
|
ENDDO
|
|
ELSEIF(IMAT(N) .NE. 999 .AND. NCORN(N) .LE. 5 .AND. (IMAT(N) .LT. 900 .OR. IMAT(N) .GT. 903)) THEN
|
|
ILINEL=1
|
|
IF(NCORN(N) .EQ. 5) THEN
|
|
DO K=1,5,4
|
|
J=NOP(N,K)
|
|
MSN(J)=MSN(J)-1
|
|
ICONNCT(J,-MSN(J))=N
|
|
ENDDO
|
|
ELSE
|
|
DO K=1,3,2
|
|
J=NOP(N,K)
|
|
MSN(J)=MSN(J)-1
|
|
ICONNCT(J,-MSN(J))=N
|
|
ENDDO
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
|
|
! WORK THROUGH OUTSIDE NODES FORMING UP TO 10 CONTIUOUS SEQUENCES
|
|
|
|
DO K=1,10
|
|
JJ=0
|
|
DO J=1,NP
|
|
IF(MSN(J) .EQ. 1) THEN
|
|
MTYP(K)=1
|
|
!
|
|
! THIS IS A STARTING POINT EXTRACT A CORNER NODE
|
|
IOUTLST(K,1)=ICONNCT(J,1)
|
|
if(ipos .eq. 1) then
|
|
IOUTLST(K,2)=ICONNCT(J,2)
|
|
JJ=2
|
|
else
|
|
IOUTLST(K,2)=J
|
|
IOUTLST(K,3)=ICONNCT(J,2)
|
|
JJ=3
|
|
endif
|
|
N=ICONNCT(J,3)
|
|
IF(NOP(N,7) .EQ. 0) THEN
|
|
XCEN(K)=(XUSR(NOP(N,1))+XUSR(NOP(N,3))+XUSR(NOP(N,5)))/3.
|
|
YCEN(K)=(YUSR(NOP(N,1))+YUSR(NOP(N,3))+YUSR(NOP(N,5)))/3.
|
|
ELSE
|
|
XCEN(K)=(XUSR(NOP(N,1))+XUSR(NOP(N,3))+XUSR(NOP(N,5))+XUSR(NOP(N,7)))/4.
|
|
YCEN(K)=(YUSR(NOP(N,1))+YUSR(NOP(N,3))+YUSR(NOP(N,5))+YUSR(NOP(N,7)))/4.
|
|
ENDIF
|
|
MSN(J)=0
|
|
ICONNCT(J,1)=0
|
|
ICONNCT(J,2)=0
|
|
|
|
! NOW LOOK FOR A CONNECTION TO ICONNCT(J,2)
|
|
|
|
100 CONTINUE
|
|
DO L=1,NP
|
|
IF(MSN(L) .EQ. 1) THEN
|
|
IF(ICONNCT(L,1) .EQ. IOUTLST(K,JJ)) THEN
|
|
|
|
! FOUND ONE
|
|
|
|
if(ipos .eq. 2) then
|
|
IOUTLST(K,JJ+1)=ICONNCT(L,2)
|
|
JJ=JJ+1
|
|
else
|
|
IOUTLST(K,JJ+1)=L
|
|
IOUTLST(K,JJ+2)=ICONNCT(L,2)
|
|
JJ=JJ+2
|
|
endif
|
|
MSN(L)=0
|
|
ICONNCT(L,1)=0
|
|
JTEMP=ICONNCT(L,2)
|
|
ICONNCT(L,2)=0
|
|
IF(JTEMP .EQ. IOUTLST(K,1)) GO TO 200
|
|
GO TO 100
|
|
ELSEIF(ICONNCT(L,2) .EQ. IOUTLST(K,JJ)) THEN
|
|
|
|
! FOUND ONE THE OPPOSITE WAY
|
|
|
|
IOUTLST(K,JJ+1)=L
|
|
IOUTLST(K,JJ+2)=ICONNCT(L,1)
|
|
JJ=JJ+2
|
|
MSN(L)=0
|
|
JTEMP=ICONNCT(L,1)
|
|
ICONNCT(L,1)=0
|
|
ICONNCT(L,2)=0
|
|
IF(JTEMP .EQ. IOUTLST(K,1)) GO TO 200
|
|
GO TO 100
|
|
ENDIF
|
|
|
|
ENDIF
|
|
ENDDO
|
|
ELSEIF(MSN(J) .EQ. -1) THEN
|
|
MTYP(K)=-1
|
|
JJ=J
|
|
JO=J
|
|
LL=1
|
|
NN=ICONNCT(JJ,LL)
|
|
IOUTLST(K,LL)=JJ
|
|
130 LL=LL+1
|
|
IF(NCORN(NN) .EQ. 5) THEN
|
|
NNOP=5
|
|
ELSE
|
|
NNOP=3
|
|
ENDIF
|
|
IF(NOP(NN,1) .EQ. JJ) THEN
|
|
JJ=NOP(NN,NNOP)
|
|
JL=NOP(NN,3)
|
|
IOUTLST(K,LL)=JL
|
|
ELSE
|
|
JJ=NOP(NN,1)
|
|
JL=JJ
|
|
IOUTLST(K,LL)=JJ
|
|
ENDIF
|
|
CALL GETLINANG(ANGL,JO,JJ)
|
|
ANGL1=ANGL-PI2
|
|
IF(LL .EQ. 2) THEN
|
|
XOUT(1,K)=XUSR(JO)+WIDTH(JO)/2.*COS(ANGL1)
|
|
YOUT(1,K)=YUSR(JO)+WIDTH(JO)/2.*SIN(ANGL1)
|
|
XOUT(4999,K)=XUSR(JO)-WIDTH(JO)/2.*COS(ANGL1)
|
|
YOUT(4999,K)=YUSR(JO)-WIDTH(JO)/2.*SIN(ANGL1)
|
|
ENDIF
|
|
XOUT(LL,K)=XUSR(JL)+WIDTH(JL)/2.*COS(ANGL1)
|
|
YOUT(LL,K)=YUSR(JL)+WIDTH(JL)/2.*SIN(ANGL1)
|
|
XOUT(5000-LL,K)=XUSR(JL)-WIDTH(JL)/2.*COS(ANGL1)
|
|
YOUT(5000-LL,K)=YUSR(JL)-WIDTH(JL)/2.*SIN(ANGL1)
|
|
|
|
IF(MSN(JJ) .EQ. -1) GO TO 150
|
|
IF(ICONNCT(JJ,1) .EQ. NN) THEN
|
|
NN=ICONNCT(JJ,2)
|
|
ELSE
|
|
NN=ICONNCT(JJ,1)
|
|
ENDIF
|
|
GO TO 130
|
|
150 MSN(JJ)=0
|
|
JJ=LL
|
|
DO JJJ=LL,1,-1
|
|
JJ=JJ+1
|
|
XOUT(JJ,K)=XOUT(5000-JJJ,K)
|
|
YOUT(JJ,K)=YOUT(5000-JJJ,K)
|
|
ENDDO
|
|
JJ=JJ+1
|
|
XOUT(JJ,K)=XOUT(1,K)
|
|
YOUT(JJ,K)=YOUT(1,K)
|
|
MSN(J)=0
|
|
GO TO 200
|
|
ENDIF
|
|
ENDDO
|
|
GO TO 300
|
|
200 CONTINUE
|
|
NOUTLST(K)=JJ
|
|
IF(JJ .GT. 0) THEN
|
|
IF(IOUTSW .EQ. 1) THEN
|
|
NDIM=2
|
|
NZERO=0
|
|
NONE=1
|
|
WRITE(IOUTOUT,*)NOUTLST(K)-1,NDIM,NZERO,NZERO
|
|
DO L=1,NOUTLST(K)-1
|
|
WRITE(IOUTOUT,*) L,XUSR(IOUTLST(K,L)),YUSR(IOUTLST(K,L))
|
|
ENDDO
|
|
WRITE(IOUTOUT,*) NOUTLST(K)-1,NZERO
|
|
DO I=1,NOUTLST(K)-2
|
|
WRITE(IOUTOUT,*) I,I,I+1
|
|
ENDDO
|
|
WRITE(IOUTOUT,*) NOUTLST(K)-1,NOUTLST(K)-1,NONE
|
|
|
|
WRITE(IOUTOUT,*) NZERO
|
|
ELSE
|
|
DO L=1,NOUTLST(K)
|
|
IF(MTYP(K) .EQ. 1) THEN
|
|
XOUT(L,K)=XUSR(IOUTLST(K,L))
|
|
YOUT(L,K)=YUSR(IOUTLST(K,L))
|
|
ENDIF
|
|
IF(IOUTSW .EQ. 0) THEN
|
|
WRITE(IOUTOUT,*) XOUT(L,K),YOUT(L,K)
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
300 CONTINUE
|
|
DO K=1,10
|
|
IF(NOUTLST(K) .EQ. 0) GO TO 400
|
|
IF(MTYP(K) .EQ. 1) THEN
|
|
LSTAT=IGrInsidePolygon(XOUT(1,K),YOUT(1,K),NOUTLST(K),XCEN(K),YCEN(K))
|
|
ELSE
|
|
LSTAT=.TRUE.
|
|
ENDIF
|
|
IF(LSTAT) THEN
|
|
NOUTLST(K)=ABS(NOUTLST(K))
|
|
ELSE
|
|
NOUTLST(K)=-ABS(NOUTLST(K))
|
|
ENDIF
|
|
ENDDO
|
|
400 CONTINUE
|
|
RETURN
|
|
END
|
|
|
|
SUBROUTINE GETLINANG(angle,n1,n2)
|
|
USE BLK1MOD
|
|
! use ATAN2 and angle into range 0 to 2*pi
|
|
ANGLE=ATAN2(YUSR(N2)-YUSR(N1),XUSR(N2)-XUSR(N1))
|
|
IF(ANGLE .LT. 0.) ANGLE=ANGLE+6.28318515
|
|
RETURN
|
|
END
|
|
|