!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