! Last change: IPK 2 Mar 1999 12:58 pm !IPK NEW ROUTINE OCT 23 1996 SUBROUTINE CCLINE(ISW) ! ! Generate continuity lines ! USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' CHARACTER*1 IFLAG DIMENSION XLIN(350),YLIN(350),INODE1(350) ! DIMENSION ICN(MAXP) LOGICAL :: OPENED DO J=1,MAXP ICN(J)=0 ENDDO IF(ISW .EQ. 1) THEN call opencln(ipos) if(ipos .eq. 0) return ELSE ipos=2 ENDIF ! ! First sort out the potential midsides ! Note that transition elements caues a problem ! Find these first DO N=1,NE IF(NCORN(N) .EQ. 5 .AND. IMAT(N) .LT. 901) THEN ! ! We have a transition mark node number as if it were corner ! ICN(NOP(N,3))=1 ICN(NOP(N,1))=2 ICN(NOP(N,4))=2 ICN(NOP(N,5))=2 ELSE ! ! Store ICN = 2 for corner nodes ! NCN=NCORN(N) !IPKOCT93 IF(IMAT(N) .GT. 900) THEN IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN MST=1 ELSE MST=2 ENDIF DO M=1,NCN,MST ICN(NOP(N,M))=2 ENDDO ENDIF ENDDO ! ! Get connections ! CALL NTONCON(ipos) 100 CONTINUE NHTP=0 NMESS=26 NBRR=8 NTRACT=0 CALL HEDR NCLL=0 ! ! Get first point ! 110 CONTINUE K=1 CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE1(1),IFLAG,INSKP,IBOX) if(inode1(1) .eq. 0) go to 110 IF(IRMAIN .EQ. 1) THEN NTRACT=0 RETURN ENDIF IF(IFLAG .EQ. 'q') THEN NTRACT=0 GO TO 500 ENDIF !IPK JAN01 IF(IBOX .EQ. 7 .OR. IFLAG .EQ. 'n' .or. & IBOX .EQ. 5 .OR. IFLAG .EQ. 'd') THEN ipos=ncll+1 CALL GETCLN(ipos) !IPK JAN02 IF(ISW .EQ. 1) THEN IF(IPOS .EQ. 0) THEN DO NCLL=1,140 DO KK=1,350 ICCLN(NCLL,KK)=0 ENDDO ENDDO NCLM=0 ELSE ncll=ipos DO KK=1,350 ICCLN(NCLL,KK)=0 ENDDO IF(NCLM .EQ. NCLL) NCLM=NCLM-1 ENDIF GO TO 100 ENDIF ENDIF IF(ICN(INODE1(1)) .NE. 2) THEN NMESS=28 CALL HEDR GO TO 110 ENDIF NBRR=5 NMESS=27 CALL HEDR fpn=inode1(1) CALL NUMBR(0.5,7.2,0.2,FPN,0.0,-1) call pltnod(inode1(1),0) ! ! Get second point ! 150 CONTINUE K=K+1 160 CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE1(K),IFLAG,INSKP,IBOX) IF(IRMAIN .EQ. 1) THEN NTRACT=0 RETURN ENDIF IF(IFLAG .EQ. 'q') THEN NTRACT=0 GO TO 500 ENDIF NMESS=26 CALL HEDR IF(IBOX .EQ. 6 .OR. IFLAG .EQ. 'b' ) THEN K=K-2 GO TO 150 ELSEIF(IBOX .EQ. 7 .OR. IFLAG .EQ. 'n') THEN KL=K-2 IF(ISW .EQ. 1) THEN !IPK Get continuity line number ipos=ncll+1 CALL GETCLN(ipos) ncll=ipos IF(NCLL .EQ. 0) GO TO 500 ENDIF ! ! Trace along line ! NTRACT=1 IF(KL .GT. 0) THEN DO LS=1,KL CALL TRACE(INODE1(LS),INODE1(LS+1)) ENDDO ELSE NTRACT=1 ITRAC(1)=INODE1(1) ENDIF ! ! Output line to file ! ! WRITE(90,6000) (ITRAC(KK),KK=1,NTRAC) !ipk jan01 INQUIRE(98, OPENED=OPENED) if(opened) then IF(IPOS .EQ. 1) THEN DO KK=1,NTRACT WRITE(98,6001) ITRAC(KK),XUSR(ITRAC(KK)),YUSR(ITRAC(KK)) 6001 FORMAT('NODE',I7,2F15.3) ENDDO ELSE WRITE(98,6000) NCLL,(ITRAC(KK),KK=1,NTRACT) ENDIF endif !IPK JAN01 6000 FORMAT('CC1',I5,9I8/('CC2',5X,9I8)) DO KK=1,NTRACT XLIN(KK)=CORD(ITRAC(KK),1) YLIN(KK)=CORD(ITRAC(KK),2) ENDDO !ipk jan01 ! Save to an array by line number ! IF(ISW .EQ. 1) THEN DO KK=1,NTRACT ICCLN(NCLL,KK)=ITRAC(KK) ENDDO IF(NCLL .GT. NCLM) NCLM=NCLL ENDIF CALL RRED !ipk jan01 CALL THICKL CALL DASHLN(XLIN,YLIN,NTRACT,0) !ipk jan01 CALL THINL ! ! Go to get another line ! IF(ISW .EQ. 2) RETURN GO TO 100 ELSE IF(ICN(INODE1(K)) .NE. 2) THEN NMESS=27 CALL HEDR GO TO 160 ENDIF KL=K-1 ! ! Trace along line ! call pltnod(inode1(1),0) NTRACT=1 DO LS=1,KL CALL TRACE(INODE1(LS),INODE1(LS+1)) call pltnod(inode1(ls+1),0) ENDDO if(ntracT .gt. 0) then DO KK=1,NTRACT if(itrac(kk) .eq. 0) go to 300 XLIN(KK)=CORD(ITRAC(KK),1) YLIN(KK)=CORD(ITRAC(KK),2) ENDDO CALL RRED !ipk jan01 CALL THICKL CALL DASHLN(XLIN,YLIN,NTRACT,0) !ipk jan01 CALL THINL endif 300 CONTINUE fpn=inode1(KL+1) CALL NUMBR(0.5+KL*0.5,7.2,0.2,FPN,0.0,-1) ! ! Get another point ! GO TO 150 ENDIF ! ! Exit ! 500 CONTINUE END SUBROUTINE NTONCON(ipos) ! ! Generate Connections ! USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' ! ! Initialize to zero ! NCM=MAXECON DO N=1,NP DO L=1,NCM NECON(N,L)=0 ENDDO ENDDO ! ! Loop on elements ! DO N=1,NE ! ! Check to see that this element is active ! IF(IMAT(N) .NE. 0) THEN NCN=NCORN(N) ! ! Search to see if connection M and K made ! ! DO M=1,NCN,2 DO M=1,NCN,ipos ! IF(M .GT. NCN-1) GO TO 200 ! K=M+2 K=M+ipos IF(K .GT. NCN) K=1 DO L=1,NCM IF(NECON(NOP(N,M),L) .EQ. 0) THEN ! ! This is new connection ! NECON(NOP(N,M),L)=NOP(N,K) GO TO 150 ELSEIF(NECON(NOP(N,M),L) .EQ. NOP(N,K)) THEN ! ! This is an old connection ! GO TO 150 ENDIF ENDDO 150 CONTINUE ! ! Now look in the revers direction ! DO L=1,NCM IF(NECON(NOP(N,K),L) .EQ. 0) THEN NECON(NOP(N,K),L)=NOP(N,M) ! ! This is new connection ! GO TO 175 ELSEIF(NECON(NOP(N,K),L) .EQ. NOP(N,M)) THEN ! ! This is an old connection ! GO TO 175 ENDIF ENDDO 175 CONTINUE ENDDO ENDIF 200 CONTINUE ENDDO ! RETURN END SUBROUTINE TRACE(INODE1,INODE2) ! ! Generate continuity lines ! USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' DIST(N,M)=(cord(n,1)-cord(m,1))**2+(cord(n,2)-cord(m,2))**2 ! ! Start at INODE1 ! ITRAC(NTRACT)=INODE1 LAT=INODE1 100 CONTINUE ! ! Look for new nearer node to INODE2 ! CURR=1.E30 LAT1=0 DO K=1,NCM LATTMP=NECON(LAT,K) IF(LATTMP .NE. 0) THEN IF(DIST(INODE2,LATTMP) .LT. CURR) THEN LAT1=LATTMP CURR=DIST(INODE2,LATTMP) ENDIF ELSE GO TO 150 ENDIF ENDDO 150 CONTINUE IF(LAT1 .EQ. 0) RETURN NTRACT=NTRACT+1 ITRAC(NTRACT)=LAT1 IF(LAT1 .EQ. INODE2) RETURN IF(NTRACT .GT. 350) RETURN LAT=LAT1 GO TO 100 END subroutine opencln(ipos) use winteracter implicit none include 'd.inc' CHARACTER(LEN=255) :: FNAME CHARACTER(LEN=3) :: SUB LOGICAL :: OPENED INTEGER :: IPOS,IERR ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE INQUIRE(98, OPENED=OPENED) if(.not. opened) then CALL WSelectFile(ID_STRING8,SaveDialog+PromptOn,FNAME,'Save continuity line') IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN SUB='cln' CALL ADDSUB(FNAME,SUB) open(98,file=fname, form='formatted', status='unknown') ENDIF endif 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 return endif ipos= 0 RETURN enddo ipos= 2 RETURN END !ipk jan01 subroutine getcln(ipos) use winteracter implicit none include 'd.inc' INTEGER :: IPOS,IERR ! ! Declare window-type and message variables ! TYPE(WIN_STYLE) :: WINDOW TYPE(WIN_MESSAGE) :: MESSAGE call wdialogload(IDD_DIALOG010) ierr=infoerror(1) CALL WDialogSelect(IDD_DIALOG010) ierr=infoerror(1) CALL WDialogPutINTEGER(IDF_INTEGER1,IPOS) write(90,*) 'iposin',ipos CALL WDialogShow(-1,-1,0,Modal) ierr=infoerror(1) do IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN CALL WDialogGetINTEGER(IDF_INTEGER1,IPOS) write(90,*) 'iposout',ipos return endif return enddo RETURN END SUBROUTINE CHKLIN ! ! Generate continuity lines ! USE BLK1MOD USE BLK2MOD ! INCLUDE 'BLK1.COM' ! INCLUDE 'BLK2.COM' IPOS=2 CALL NTONCON(ipos) DO I=1,NCLM NTRACT=1 ITRAC(1)=ICCLN(I,1) DO J=1,350 INODE1=ICCLN(I,J) INODE2=ICCLN(I,J+1) IF(INODE2 .EQ. 0) GO TO 300 CALL TRACE(INODE1,INODE2) ENDDO 300 DO J=1,NTRACT ICCLN(I,J)=ITRAC(J) ENDDO ENDDO RETURN END