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