!IPK NEW ROUTINE SEP 9 2006 SUBROUTINE FORM999(ISWT9,iswtw,NELC) ! ! 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(5000),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) ! ! WRITE(150,*) 'IN FORM999',ISWT9,iswtw,NELC ! FLUSH(150) if(iswtw .eq. 1) THEN IFRMEL=0 IGTWEL=0 CALL ADD999(ISWT9,NELC) RETURN ENDIF CALL WMessageBox(YesNo, QuestionIcon, 1,'Are 1-D elements already formed?','1-D ELEMENTS') ! If answer 'Yes' set ifrmel to 0 ! IF (WInfoDialog(4) .EQ. 2) then IFRMEL=1 !NO ! WRITE(150,*) 'GOING TO FROM1DEL' ! FLUSH(150) CALL FORM1DEL ! WRITE(150,*) 'BACK FROM FROM1DEL' ! FLUSH(150) ELSE !YES IFRMEL=0 CALL WMessageBox(YesNo, QuestionIcon, 1,'Is width data available?','WIDTH DATA') ! If answer 'Yes' set igtwel to 0 ! IF (WInfoDialog(4) .EQ. 2) then !NO IGTWEL=1 CALL SETWID ! WRITE(150,*) 'BACK FROM SETWID' ! FLUSH(150) ELSE !YES IGTWEL=0 ! CALL CCLINE(2) ! WRITE(150,*) 'GOING TO ADD999' ! FLUSH(150) ! temp may20 CALL ADD999(ISWT9,NELC) ! tep may20 GO TO 100 ! WRITE(150,*) 'BACK FROM ADD999' ! FLUSH(150) CALL HEDR RETURN ENDIF 100 CONTINUE ENDIF ! GET NODAL CONNECTIONS ! WRITE(150,*) 'ABOUT TO GO TO NDNECON' ! FLUSH(150) IERR=0 CALL NDNECON(IERR) ! START ALONG LINE OF ELEMENTS DO N=1,NTRAC N1=ITRAC(N) IF(N .GT. 1) THEN N0=ITRAC(N-1) ENDIF IF(N .LT. NTRAC) THEN N2=ITRAC(N+1) ENDIF ! Get direction IF(N .EQ. 1) THEN DIRX=XUSR(N2)-XUSR(N1) DIRY=YUSR(N2)-YUSR(N1) DIRL(N)=ATAN2(DIRX,-DIRY) ELSEIF(N .EQ. NTRAC) 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 NNEL=6 DO N=1,NTRAC ! WRITE(150,*) 'STARTING NTRAC ITRAC',N,ITRAC(N) N1=ITRAC(N) DO M=1,NNEL/2 CALL GETNOD(J) JTRAC(N,M)=J XUSR(J)=XUSR(N1)-(WIDTH(N1)*M)/(NNEL)*COS(DIRL(N)) YUSR(J)=YUSR(N1)-(WIDTH(N1)*M)/(NNEL)*SIN(DIRL(N)) CORD(J,1)=(XUSR(J)+XS)/TXSCAL CORD(J,2)=(YUSR(J)+YS)/TXSCAL INEW(J)=1 INSKP(J) = 0 WD(J)=-9999. WIDTH(J)=0. SS1(J)=0. SS2(J)=0. WIDS(J)=0. WIDBS(J)=0. SSO(J)=0. CALL GETNOD(J1) KTRAC(N,M)=J1 XUSR(J1)=XUSR(N1)+(WIDTH(N1)*M)/NNEL*COS(DIRL(N)) YUSR(J1)=YUSR(N1)+(WIDTH(N1)*M)/NNEL*SIN(DIRL(N)) CORD(J1,1)=(XUSR(J1)+XS)/TXSCAL CORD(J1,2)=(YUSR(J1)+YS)/TXSCAL INEW(J1)=1 INSKP(J1) = 0 WD(J1)=-9999. WIDTH(J1)=0. SS1(J1)=0. SS2(J1)=0. WIDS(J1)=0. WIDBS(J1)=0. SSO(J1)=0. ENDDO ENDDO DO N=1,NTRAC-1 DO M=1,NNEL/2 CALL GETELM(J) IF(M .EQ. 1) THEN NOP(J,1)=ITRAC(N+1) NOP(J,3)=ITRAC(N) NOP(J,5)=JTRAC(N,1) NOP(J,7)=JTRAC(N+1,1) ELSE NOP(J,1)=JTRAC(N+1,M-1) NOP(J,3)=JTRAC(N,M-1) NOP(J,5)=JTRAC(N,M) NOP(J,7)=JTRAC(N+1,M) ENDIF NOP(J,2)=0 NOP(J,4)=0 NOP(J,6)=0 NOP(J,8)=0 IMAT(J)=999 NCORN(J) = 8 IESKP(J) = 0 CALL GETELM(J) IF(M .EQ. 1) THEN NOP(J,1)=ITRAC(N) NOP(J,3)=ITRAC(N+1) NOP(J,5)=KTRAC(N+1,1) NOP(J,7)=KTRAC(N,1) ELSE NOP(J,1)=KTRAC(N,M-1) NOP(J,3)=KTRAC(N+1,M-1) NOP(J,5)=KTRAC(N+1,M) NOP(J,7)=KTRAC(N,M) ENDIF NOP(J,2)=0 NOP(J,4)=0 NOP(J,6)=0 NOP(J,8)=0 IMAT(J)=999 NCORN(J) = 8 IESKP(J) = 0 NE = MAX(J,NE) ENDDO ENDDO NE = MAX(J,NE) RETURN END SUBROUTINE FORM1DEL USE WINTERACTER USE BLK1MOD USE BLK2MOD include 'd.inc' ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' INCLUDE 'TXFRM.COM' CHARACTER*1 IFLAG ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE integer :: N1,N2,N3,IERR CALL WMessageBox(YesNo, QuestionIcon, 1,'Are 1-D nodes already defined?','FORM 1-D ELEMENTS') ! If answer 'Yes' set ifrmel to 0 ! IF (WInfoDialog(4) .ne. 2) then ! yes CALL FRMEL(1) ELSE ! no CALL WMessageBox(YesNo, QuestionIcon, 1,'Use same width etc properties ?','FORM 1-D ELEMENTS') ! If answer 'Yes' set IGWID=1 ! IF (WInfoDialog(4) .ne. 2) then ! yes IGWID=1 ELSE IGWID=0 ! no ENDIF CALL WMessageBox(OKCancel, 4, 1,'Click on each node to form elements?'//CHAR(13)// & 'Then click quit to continue','FORM 1-D ELEMENTS') JREF=0 NTRAC=0 NHTP=0 NBRR=3 NMESS=15 CALL HEDR 100 CONTINUE CALL XYLOC(XX,YY,IFLAG,IBOX) IF(IRMAIN .EQ. 1) RETURN IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN GO TO 200 ENDIF ! IF (IFLAG .EQ. 'c') THEN ! call getnod(j) NTRAC=NTRAC+1 ITRAC(NTRAC)=J INSKP(J)=0 CORD(J,1) = XX CORD(J,2) = YY INEW(J) = 1 ! XUSR(J) = XX*TXSCAL - XS YUSR(J) = YY*TXSCAL - YS IF (J .GT. NP) NP = J call pltnod(j,1) IF(JREF .EQ.0) THEN WIDTH(J)=50. call nodedisp(j) ELSE WIDTH(J)=WIDTH(J1) WD(J)=WD(J1) SS1(J)=SS1(J1) SS2(J)=SS2(J1) WIDS(J)=WIDS(J1) WIDBS(J)=WIDBS(J1) SSO(J)=SSO(J1) BS1(J)=BS1(J1) IF(IGWID .EQ. 0) THEN call nodedisp(j) ENDIF CALL PLTNOD(J,0) call getelm(k) NOP(K,1)=J1 NOP(K,2)=0 NOP(K,3)=J NCORN(K)=3 IMAT(K)=1 IESKP(K) = 0 NE = MAX(K,NE) IERC=0 CALL PLTELM(K,IERC) ENDIF J1=J JREF=1 GO TO 100 ENDIF ENDIF 200 CONTINUE call clscrn CALL PLOTOT(1) NHTP=1 NMESS=0 NBRR=0 CALL HEDR RETURN END SUBROUTINE SETWID CALL FRMEL(0) RETURN END SUBROUTINE FRMEL(ISW) USE WINTERACTER USE BLK1MOD USE BLK2MOD include 'd.inc' ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' INCLUDE 'TXFRM.COM' CHARACTER*1 IFLAG ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE integer :: N1,N2,N3,IERR NHTP=0 NBRR=3 NMESS=15 CALL HEDR IF(ISW .EQ. 1) THEN CALL WMessageBox(YesNo, QuestionIcon, 1,'Is width data available?','WIDTH DATA') ! If answer 'Yes' set igtwel to 0 ! IF (WInfoDialog(4) .EQ. 2) then !NO IGTWEL=1 ELSE !YES IGTWEL=0 ENDIF ELSE IGTWEL=1 ENDIF IF(IGTWEL .EQ. 1) THEN CALL WMessageBox(YesNo, QuestionIcon, 1,'Use same width etc properties ?','FORM 1-D ELEMENTS') ! If answer 'Yes' set IGWID=1 ! IF (WInfoDialog(4) .ne. 2) then ! yes IGWID=1 ELSE IGWID=0 ! no ENDIF ENDIF NTRAC=0 100 CONTINUE CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,J,IFLAG,INSKP,IBOX) IF(IRMAIN .EQ. 1) RETURN IF(IFLAG .EQ. 'q' .OR. (IFLAG .EQ. 'c' .AND. IBOX .EQ. 10))THEN GO TO 200 ENDIF ! IF (IFLAG .EQ. 'c') THEN ! IF(IGTWEL .EQ. 1) THEN IF(NTRAC .EQ. 0) THEN call nodedisp(j) ELSE WIDTH(J)=WIDTH(J1) WD(J)=WD(J1) SS1(J)=SS1(J1) SS2(J)=SS2(J1) WIDS(J)=WIDS(J1) WIDBS(J)=WIDBS(J1) SSO(J)=SSO(J1) BS1(J)=BS1(J1) IF(IGWID .EQ. 0) THEN call nodedisp(j) ENDIF ENDIF ENDIF CALL PLTNOD(J,0) ! IF(ISW .EQ. 1) THEN if(ntrac .ne. 0) then call getelm(k) NOP(K,1)=J1 NOP(K,2)=0 NOP(K,3)=J NCORN(K)=3 IMAT(K)=1 IESKP(K) = 0 NE = MAX(K,NE) IERC=0 CALL PLTELM(K,IERC) ENDIF J1=J NTRAC=NTRAC+1 ITRAC(NTRAC)=J GO TO 100 ENDIF 200 CONTINUE RETURN END