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.
497 lines
15 KiB
Fortran
497 lines
15 KiB
Fortran
5 years ago
|
! 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
|