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.
345 lines
7.8 KiB
Fortran
345 lines
7.8 KiB
Fortran
!IPK NEW ROUTINE SEP 9 2006
|
|
SUBROUTINE SPLITN
|
|
!
|
|
! Generate continuity lines
|
|
!
|
|
|
|
USE WINTERACTER
|
|
USE BLK1MOD
|
|
USE BLK2MOD
|
|
include 'd.inc'
|
|
|
|
! INCLUDE 'BLK1.COM'
|
|
! INCLUDE 'BLK2.COM'
|
|
INCLUDE 'TXFRM.COM'
|
|
CHARACTER*1 IFLAG
|
|
DIMENSION DIRL(350),IPROCES(MAXE)
|
|
!
|
|
! Declare window-type and message variables
|
|
!
|
|
TYPE(WIN_STYLE) :: WINDOW
|
|
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
|
|
|
integer :: N1,N2,N3,IERR
|
|
|
|
DATA SPAC/10./,ieltyp/1/,ielsw/1/,iensw/0/
|
|
|
|
! DIST(N1,N2)=SQRT((CORD(N1,1)-CORD(N2,1))**2 &
|
|
! & +(CORD(N1,2)-CORD(N2,2))**2)
|
|
PROJ(N1,N2,DR)= (CORD(N2,1)-CORD(N1,1))*COS(DR)+(CORD(N2,2)-CORD(N1,2))*SIN(DR)
|
|
!
|
|
icln=1
|
|
dirsplIt=0.
|
|
ieltyp=1
|
|
ientyp=1
|
|
SPAC=10.
|
|
call wdialogload(IDD_DISPLIT)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogSelect(IDD_DISPLIT)
|
|
ierr=infoerror(1)
|
|
|
|
call wdialogputradiobutton(idf_radio1)
|
|
CALL WDialogPutinteger(IDF_INTEGER3,icln)
|
|
CALL WDialogPutReal(IDF_REAL1,SPAC)
|
|
CALL WDialogPutinteger(IDF_INTEGER2,IELTYP)
|
|
call wdialogputcheckbox(IDF_check1,ielsw)
|
|
call wdialogputcheckbox(IDF_check2,iensw)
|
|
CALL WDialogPutinteger(IDF_INTEGER6,IENTYP)
|
|
CALL WDialogPutReal(IDF_REAL2,DIRSPLIT)
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
|
ierr=infoerror(1)
|
|
|
|
do
|
|
!
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
|
|
|
call wdialoggetradiobutton(idf_radio1,iswr)
|
|
CALL WDialogGetinteger(IDF_INTEGER3,icln)
|
|
CALL WDialogGetREAL(IDF_REAL1,SPAC)
|
|
CALL WDialogGetinteger(IDF_INTEGER2,IELTYP)
|
|
call wdialogGetcheckbox(IDF_check1,ielsw)
|
|
call wdialogGetcheckbox(IDF_check2,iensw)
|
|
CALL WDialogGetinteger(IDF_INTEGER6,IENTYP)
|
|
CALL WDialogGetREAL(IDF_REAL2,DIRSPLIT)
|
|
GO TO 100
|
|
ENDIF
|
|
|
|
enddo
|
|
|
|
100 CONTINUE
|
|
|
|
if(iswr .eq. 1) then
|
|
CALL CCLINE(2)
|
|
else
|
|
DO KK=1,350
|
|
if(iccln(icln,KK) .eq. 0) then
|
|
ntract=kk-1
|
|
go to 102
|
|
endif
|
|
itrac(kk)=ICCLN(icln,KK)
|
|
enddo
|
|
102 continue
|
|
endif
|
|
DO N=1,NTRACT
|
|
|
|
N1=ITRAC(N)
|
|
IF(N .GT. 1) THEN
|
|
N0=ITRAC(N-1)
|
|
ENDIF
|
|
IF(N .LT. NTRACT) THEN
|
|
N2=ITRAC(N+1)
|
|
ENDIF
|
|
|
|
! Get direction
|
|
|
|
IF(N .EQ. 1) THEN
|
|
IF(NTRACT .GT. 1) THEN
|
|
DIRX=XUSR(N2)-XUSR(N1)
|
|
DIRY=YUSR(N2)-YUSR(N1)
|
|
DIRL(N)=ATAN2(DIRX,-DIRY)
|
|
ELSE
|
|
DIRL(N)=DIRSPLIT
|
|
ENDIF
|
|
ELSEIF(N .EQ. NTRACT) THEN
|
|
DIRX=XUSR(N1)-XUSR(N0)
|
|
DIRY=YUSR(N1)-YUSR(N0)
|
|
DIRL(N)=ATAN2(DIRX,-DIRY)
|
|
ELSE
|
|
DIRX=XUSR(N2)-XUSR(N0)
|
|
DIRY=YUSR(N2)-YUSR(N0)
|
|
DIRL(N)=ATAN2(DIRX,-DIRY)
|
|
ENDIF
|
|
ENDDO
|
|
! Move nodes apart adding new numbers
|
|
|
|
DO N=1,NTRACT
|
|
N1=ITRAC(N)
|
|
CALL GETNOD(J)
|
|
JTRAC(N,1)=J
|
|
XUSR(J)=XUSR(N1)-SPAC/2.*COS(DIRL(N))
|
|
YUSR(J)=YUSR(N1)-SPAC/2.*SIN(DIRL(N))
|
|
CORD(J,1)=(XUSR(J)+XS)/TXSCAL
|
|
CORD(J,2)=(YUSR(J)+YS)/TXSCAL
|
|
INEW(J)=1
|
|
INSKP(J) = 0
|
|
|
|
XUSR(N1)=XUSR(N1)+SPAC/2.*COS(DIRL(N))
|
|
YUSR(N1)=YUSR(N1)+SPAC/2.*SIN(DIRL(N))
|
|
CORD(N1,1)=(XUSR(N1)+XS)/TXSCAL
|
|
CORD(N1,2)=(YUSR(N1)+YS)/TXSCAL
|
|
WD(J)=WD(N1)
|
|
WIDTH(J)=WIDTH(N1)
|
|
SS1(J)=SS1(N1)
|
|
SS2(J)=SS2(N1)
|
|
WIDS(J)=WIDS(N1)
|
|
WIDBS(J)=WIDBS(N1)
|
|
SSO(J)=SSO(N1)
|
|
ENDDO
|
|
|
|
|
|
! Form list of elements connected to nodes
|
|
IERR=0
|
|
CALL NDNECON(IERR)
|
|
|
|
! find each element
|
|
|
|
IPROCES=0
|
|
|
|
IF(NTRACT .GT. 1) THEN
|
|
DO N=1,NTRACT-1
|
|
DO K=1,NDELM(ITRAC(N))
|
|
J=NECON(ITRAC(N),K)
|
|
! IF(IPROCES(J) .EQ. 0) THEN
|
|
IJ=0
|
|
II=0
|
|
DO L=1,NCORN(J),2
|
|
IF(NOP(J,L) .EQ. ITRAC(N) .or. NOP(J,L) .EQ. JTRAC(N,1)) II=L
|
|
IF(NOP(J,L) .EQ. ITRAC(N+1)) IJ=L
|
|
ENDDO
|
|
IF(IJ .NE. 0) THEN
|
|
IF(IJ .LT. II .OR. (II .EQ. 1 .and. ij .ne. 3) ) THEN
|
|
IF(II .EQ. NCORN(J)-1 .AND. IJ .EQ. 1) GO TO 200
|
|
! MATCH FOUND
|
|
NOP(J,II)= JTRAC(N,1)
|
|
NOP(J,IJ)= JTRAC(N+1,1)
|
|
IPROCES(J)=1
|
|
GO TO 300
|
|
ENDIF
|
|
200 CONTINUE
|
|
IPROCES(J)=1
|
|
ENDIF
|
|
300 CONTINUE
|
|
! ENDIF
|
|
ENDDO
|
|
ENDDO
|
|
|
|
ENDIF
|
|
|
|
DO N=1,NTRACT
|
|
DO K=1,NDELM(ITRAC(N))
|
|
J=NECON(ITRAC(N),K)
|
|
IF(IPROCES(J) .EQ. 0) THEN
|
|
II=0
|
|
DO L=1,NCORN(J),2
|
|
IF(NOP(J,L) .EQ. ITRAC(N)) II=L
|
|
ENDDO
|
|
IF(II .NE. 0) THEN
|
|
A0P=-9999.
|
|
A0M=9999.
|
|
B0P=-9999.
|
|
B0M=9999.
|
|
DO L=1,NCORN(J),2
|
|
IF(II .NE. NOP(J,L)) THEN
|
|
ITEST=NOP(J,L)
|
|
ENDIF
|
|
A1=PROJ(ITEST,ITRAC(N),DIRL(N))
|
|
IF(A1 .GT. A0P) A0P=A1
|
|
IF(A1 .LT. A0M) A0M=A1
|
|
B1=PROJ(ITEST,JTRAC(N,1),DIRL(N))
|
|
IF(B1 .GT. B0P) B0P=B1
|
|
IF(B1 .LT. B0M) B0M=B1
|
|
ENDDO
|
|
IF(ABS(A0M) .GT. ABS(A0P)) THEN
|
|
A0P=A0M
|
|
B0P=B0M
|
|
ENDIF
|
|
IF(ABS(A0P) .GT. ABS(B0P)) THEN
|
|
NOP(J,II)= JTRAC(N,1)
|
|
ENDIF
|
|
IPROCES(J)=1
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
ENDDO
|
|
IERR=0
|
|
CALL NDNECON(IERR)
|
|
|
|
IF(IELSW .EQ. 0) GO TO 400
|
|
! form new elements
|
|
|
|
DO N=1,NTRACT-1
|
|
CALL GETELM(J)
|
|
NOP(J,1)=JTRAC(N,1)
|
|
NOP(J,3)=JTRAC(N+1,1)
|
|
NOP(J,5)=ITRAC(N+1)
|
|
NOP(J,7)=ITRAC(N)
|
|
NOP(J,2)=0
|
|
NOP(J,4)=0
|
|
NOP(J,6)=0
|
|
NOP(J,8)=0
|
|
IMAT(J)=IELTYP
|
|
NCORN(J) = 8
|
|
IESKP(J) = 0
|
|
NE = MAX(J,NE)
|
|
ENDDO
|
|
|
|
400 CONTINUE
|
|
|
|
if(iensw .gt. 0) then
|
|
|
|
|
|
|
|
! start at first node
|
|
IF(NDELM(ITRAC(1)) .GT. 1) THEN
|
|
DO K=1,NDELM(ITRAC(1))
|
|
J=NECON(ITRAC(1),K)
|
|
DO KZ=1,NCORN(J),2
|
|
IF(NOP(J,KZ) .EQ. ITRAC(1)) THEN
|
|
K1=KZ
|
|
GO TO 500
|
|
ENDIF
|
|
ENDDO
|
|
500 KK=K1-2
|
|
IF(KK .LT. 0) KK=NCORN(J)-1
|
|
KUP=NOP(J,KK)
|
|
DO KZ=1,NDELM(KUP)
|
|
JJ=NECON(KUP,KZ)
|
|
DO KY=1,NCORN(JJ),2
|
|
IF(NOP(JJ,KY) .EQ. KUP) THEN
|
|
K2=KY
|
|
GO TO 550
|
|
ENDIF
|
|
ENDDO
|
|
550 KL=K2-2
|
|
IF(KL .LT. 0) KL=NCORN(JJ)-1
|
|
IF(NOP(JJ,KL) .EQ. JTRAC(1,1)) THEN
|
|
GO TO 600
|
|
ENDIF
|
|
ENDDO
|
|
ENDDO
|
|
|
|
! FOUND A MATCH
|
|
|
|
600 CONTINUE
|
|
CALL GETELM(JK)
|
|
NOP(JK,1)=ITRAC(1)
|
|
NOP(JK,3)=KUP
|
|
NOP(JK,5)=JTRAC(1,1)
|
|
NOP(JK,2)=0
|
|
NOP(JK,4)=0
|
|
NOP(JK,6)=0
|
|
IMAT(JK)=IENTYP
|
|
NCORN(JK) = 6
|
|
IESKP(JK) = 0
|
|
NE = MAX(JK,NE)
|
|
ENDIF
|
|
|
|
IF(NDELM(ITRAC(NTRACT)) .GT. 1) THEN
|
|
DO K=1,NDELM(ITRAC(NTRACT))
|
|
J=NECON(ITRAC(NTRACT),K)
|
|
DO KZ=1,NCORN(J),2
|
|
IF(NOP(J,KZ) .EQ. ITRAC(NTRACT)) THEN
|
|
K1=KZ
|
|
GO TO 650
|
|
ENDIF
|
|
ENDDO
|
|
650 KK=K1+2
|
|
IF(KK .GT. NCORN(J)) KK=1
|
|
KUP=NOP(J,KK)
|
|
DO KK=1,NDELM(KUP)
|
|
JJ=NECON(KUP,KK)
|
|
DO KY=1,NCORN(JJ),2
|
|
IF(NOP(JJ,KY) .EQ. KUP) THEN
|
|
K2=KY
|
|
GO TO 700
|
|
ENDIF
|
|
ENDDO
|
|
700 KL=K2+2
|
|
IF(KL .GT. NCORN(JJ)) KL=1
|
|
IF(NOP(JJ,KL) .EQ. JTRAC(NTRACT,1)) THEN
|
|
GO TO 750
|
|
ENDIF
|
|
ENDDO
|
|
ENDDO
|
|
GO TO 800
|
|
|
|
! FOUND A MATCH
|
|
|
|
750 CONTINUE
|
|
CALL GETELM(JK)
|
|
|
|
NOP(JK,1)=JTRAC(NTRACT,1)
|
|
NOP(JK,3)=KUP
|
|
NOP(JK,5)=ITRAC(NTRACT)
|
|
NOP(JK,2)=0
|
|
NOP(JK,4)=0
|
|
NOP(JK,6)=0
|
|
IMAT(JK)=IENTYP
|
|
NCORN(JK) = 6
|
|
IESKP(JK) = 0
|
|
NE = MAX(JK,NE)
|
|
ENDIF
|
|
|
|
endif
|
|
|
|
800 CONTINUE
|
|
call clscrn
|
|
CALL PLOTOT(1)
|
|
NHTP=1
|
|
NMESS=0
|
|
NBRR=0
|
|
CALL HEDR
|
|
RETURN
|
|
END |