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.
713 lines
29 KiB
Fortran
713 lines
29 KiB
Fortran
5 years ago
|
! Last change: IPK 12 Jan 98 1:59 pm
|
||
|
|
!ipk delete old calls to char(7)
|
||
|
|
!ipk last updated Nov 18 1997
|
||
|
|
!ipk last updated June 24 1996
|
||
|
|
!
|
||
|
|
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||
|
|
!
|
||
|
|
SUBROUTINE ELTS
|
||
|
|
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
CHARACTER*1 ANS,ANSW(0:9)
|
||
|
|
DATA ANSW/'s','j','f','g','t','i','h','z','r','q'/
|
||
|
|
!
|
||
|
|
! Draw box around selections
|
||
|
|
!
|
||
|
|
2 CONTINUE
|
||
|
|
NHTP=6
|
||
|
|
NMESS=0
|
||
|
|
NBRR=0
|
||
|
|
CALL HEDR
|
||
|
|
!
|
||
|
|
! Get answer
|
||
|
|
!
|
||
|
|
3 call xyloc(XPT,YPT,ANS,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
IF(ANS .EQ. 'c') THEN
|
||
|
|
I=IBOX-1
|
||
|
|
if(i .lt. 0) go to 3
|
||
|
|
ANS=ANSW(I)
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
IF(ANS .EQ. 's') THEN
|
||
|
|
CALL SELECT
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
ELSEIF (ANS .EQ. 'j') THEN
|
||
|
|
CALL MKELEM
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
ELSEIF (ANS .EQ. 'd') THEN
|
||
|
|
CALL DELEL
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
ELSEIF (ANS .EQ. 'f') THEN
|
||
|
|
CALL FINDEL
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
ELSEIF (ANS .EQ. 'g') THEN
|
||
|
|
CALL GEL
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
ELSEIF (ANS .EQ. 't') THEN
|
||
|
|
CALL MATTYP
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
ELSEIF (ANS .EQ. 'i') THEN
|
||
|
|
!ipk aug02
|
||
|
|
CALL FILM(0)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
ELSEIF (ANS .EQ. 'h') THEN
|
||
|
|
CALL HELPS(2)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
ELSEIF (ANS .EQ. 'q') THEN
|
||
|
|
RETURN
|
||
|
|
ELSE
|
||
|
|
GO TO 3
|
||
|
|
ENDIF
|
||
|
|
GO TO 2
|
||
|
|
END
|
||
|
|
!
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
SUBROUTINE MATTYP
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
SAVE
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
!ipk feb97 CHARACTER*1 IFLAG
|
||
|
|
!
|
||
|
|
CHARACTER*1 IFLAG,ANSW(10)
|
||
|
|
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Assign new material type
|
||
|
|
!
|
||
|
|
!
|
||
|
|
!
|
||
|
|
data itime/0/
|
||
|
|
|
||
|
|
if(itime .eq. 0) then
|
||
|
|
mat=1
|
||
|
|
itime=1
|
||
|
|
endif
|
||
|
|
ht=0.2
|
||
|
|
!ipk feb97
|
||
|
|
4 CONTINUE
|
||
|
|
NHTP=0
|
||
|
|
NBRR=4
|
||
|
|
!ipk feb97 NBRR=0
|
||
|
|
NMESS=45
|
||
|
|
CALL HEDR
|
||
|
|
NMESS=2
|
||
|
|
XPRT=3.2
|
||
|
|
! READ(*,*) MAT
|
||
|
|
!
|
||
|
|
! Write out current material types
|
||
|
|
!
|
||
|
|
IF(NEFL .GT. 0) GO TO 100
|
||
|
|
!ipk feb97 4 HT = .20
|
||
|
|
HT = .15
|
||
|
|
DO 10 J=1,NE
|
||
|
|
IF (IMAT(J) .GT. 0 .AND. IMAT(J) .LT. 901) THEN
|
||
|
|
IF(IESKP(J) .EQ. 0) THEN
|
||
|
|
IF(IQSW(1) .EQ. 1 .OR. IQSW(2) .EQ. 1) FPN = IMAT(J)
|
||
|
|
IF(IQSW(1) .EQ. 2 .OR. IQSW(2) .EQ. 2) FPN = IGRPSER(J)
|
||
|
|
X = XC(J)
|
||
|
|
!ipk jul02 Y = YC(J) - .11
|
||
|
|
Y = YC(J) + .01
|
||
|
|
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||
|
|
& Y .GT. 0. .AND. Y .LT. 7.5) THEN
|
||
|
|
CALL NUMBR(X,Y,HT,FPN,0.0,-1)
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
10 END DO
|
||
|
|
CALL GETINT(MAT)
|
||
|
|
|
||
|
|
5 CONTINUE
|
||
|
|
IBOX=1
|
||
|
|
CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. 9.6) XPRT=0.
|
||
|
|
FPN= IELEM
|
||
|
|
CALL NUMBR(XPRT,7.20,0.18,FPN,0.0,-1)
|
||
|
|
!ipk feb97 new setup
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'q') THEN
|
||
|
|
RETURN
|
||
|
|
ELSEIF(IFLAG .EQ. 'e' .OR. IFLAG .EQ. 'n') THEN
|
||
|
|
!ipk nov97 add (1)
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
GO TO 4
|
||
|
|
ENDIF
|
||
|
|
IF(IQSW(1) .EQ. 1 .OR. IQSW(2) .EQ. 1) IMAT(IELEM) = MAT
|
||
|
|
IF(IQSW(1) .EQ. 2 .OR. IQSW(2) .EQ. 2) IGRPSER(IELEM) = MAT
|
||
|
|
FPN = MAT
|
||
|
|
X = XC(IELEM)
|
||
|
|
Y = YC(IELEM) + .01
|
||
|
|
CALL NUMBR(X,Y,0.15,FPN,0.0,-1)
|
||
|
|
!
|
||
|
|
!ipk feb97 ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
!ipkfeb94 CALL WRTOUT(0)
|
||
|
|
!ipk feb97 RETURN
|
||
|
|
!
|
||
|
|
!ipk feb97 ELSE
|
||
|
|
!ipk feb97 WRITE(*,*) CHAR(7),CHAR(7)
|
||
|
|
!ipk feb97 ENDIF
|
||
|
|
!
|
||
|
|
GOTO 5
|
||
|
|
!
|
||
|
|
! Process list from prior selection
|
||
|
|
!
|
||
|
|
100 CONTINUE
|
||
|
|
DO 150 K=1,NEFL
|
||
|
|
J=NEFLAG(K)
|
||
|
|
IMAT(J)=MAT
|
||
|
|
150 END DO
|
||
|
|
NEFL=0
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!
|
||
|
|
SUBROUTINE FINDEL
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
SAVE NELSE
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
! Read desired element number
|
||
|
|
!
|
||
|
|
data itime/0/
|
||
|
|
if(itime .eq. 0) then
|
||
|
|
itime=1
|
||
|
|
nelse=0
|
||
|
|
endif
|
||
|
|
2 CONTINUE
|
||
|
|
NHTPSAV=NHTP
|
||
|
|
NMESSAV=NMESS
|
||
|
|
NBRRSAV=NBRR
|
||
|
|
NHTP=0
|
||
|
|
NBRR=0
|
||
|
|
NMESS=3
|
||
|
|
CALL HEDR
|
||
|
|
NMESS=3
|
||
|
|
CALL GETINT(NELSE)
|
||
|
|
! READ(*,*) NELSE
|
||
|
|
!
|
||
|
|
! Obtain location of centroid
|
||
|
|
!
|
||
|
|
!ipkdec93 IF(IMAT(NELSE) .EQ. 0) GO TO 2
|
||
|
|
IF(IMAT(NELSE) .EQ. 0) RETURN
|
||
|
|
DO 4 I=1,NP
|
||
|
|
IF(CORD(I,1) .GT. VOID) THEN
|
||
|
|
INSKP(I)=0
|
||
|
|
ENDIF
|
||
|
|
4 END DO
|
||
|
|
DO 5 I=1,NE
|
||
|
|
IF(IMAT(I) .GT. 0) THEN
|
||
|
|
IESKP(I)=0
|
||
|
|
ENDIF
|
||
|
|
5 END DO
|
||
|
|
NCN=NCORN(NELSE)
|
||
|
|
XX=0.
|
||
|
|
YY=0.
|
||
|
|
DO 150 K=1,NCN,2
|
||
|
|
XX=XX+CORD(NOP(NELSE,K),1)
|
||
|
|
YY=YY+CORD(NOP(NELSE,K),2)
|
||
|
|
150 END DO
|
||
|
|
XP=XX/FLOAT((NCN+1)/2)
|
||
|
|
YP=YY/FLOAT((NCN+1)/2)
|
||
|
|
!
|
||
|
|
! Make it center of screen and redraw
|
||
|
|
!
|
||
|
|
XMIN=XP-5.0*PSCALE
|
||
|
|
YMIN=YP-3.5*PSCALE
|
||
|
|
! CALL PLOTS(0)
|
||
|
|
!ipk nov97 add (1)
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
HT=0.15
|
||
|
|
FPN=NELSE
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(5.,3.5,HT,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
NHTP=NHTPSAV
|
||
|
|
NMESS=NMESSAV
|
||
|
|
NBRR=NBRRSAV
|
||
|
|
CALL HEDR
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!
|
||
|
|
SUBROUTINE DELEL
|
||
|
|
!
|
||
|
|
! Routine to define element for deleting
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*1 IFLAG
|
||
|
|
IF(NEFL .GT. 0) GO TO 150
|
||
|
|
100 CONTINUE
|
||
|
|
!
|
||
|
|
! Check out mouse
|
||
|
|
!
|
||
|
|
IBOX=0
|
||
|
|
CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
! Go and start again if quit called
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'q') RETURN
|
||
|
|
IECHG=0
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
CALL DELTEL(IELEM)
|
||
|
|
GO TO 100
|
||
|
|
!
|
||
|
|
! Call routine to delete elements in list
|
||
|
|
!
|
||
|
|
|
||
|
|
150 CONTINUE
|
||
|
|
IECHG=0
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
DO 200 K=1,NEFL
|
||
|
|
J=NEFLAG(K)
|
||
|
|
CALL DELTEL(J)
|
||
|
|
200 END DO
|
||
|
|
NEFL=0
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!
|
||
|
|
SUBROUTINE DELTEL(J)
|
||
|
|
!
|
||
|
|
! Routine to delete a given element
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
IMAT(J)=0
|
||
|
|
XC(J)=VOID
|
||
|
|
YC(J)=VOID
|
||
|
|
IF(J .LT. NELAST) NELAST=J
|
||
|
|
DO 170 KK=1,8
|
||
|
|
NOP(J,KK)=0
|
||
|
|
170 END DO
|
||
|
|
IESKP(J)=1
|
||
|
|
NCORN(J)=0
|
||
|
|
JJ=0
|
||
|
|
!IPK FEB08 TEST FOR LOWERING NE
|
||
|
|
IF(J .EQ. NE) THEN
|
||
|
|
DO J=NE,1,-1
|
||
|
|
IF(IMAT(J) .NE. 0) THEN
|
||
|
|
JJ=J
|
||
|
|
GO TO 200
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
200 NE=JJ
|
||
|
|
ENDIF
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!
|
||
|
|
SUBROUTINE SELECT
|
||
|
|
!
|
||
|
|
! Routine to select elements
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*1 ANSW(10)
|
||
|
|
CHARACTER*1 IFLAG
|
||
|
|
DATA ANSW/'d','e','n','a','g','t','h','z','r','q'/
|
||
|
|
data itime/0/
|
||
|
|
|
||
|
|
if(itime .eq. 0) then
|
||
|
|
ielem=1
|
||
|
|
itime=1
|
||
|
|
endif
|
||
|
|
|
||
|
|
!
|
||
|
|
! Draw box around selections
|
||
|
|
!
|
||
|
|
|
||
|
|
2 CONTINUE
|
||
|
|
!IPK MAY94 DROP THIS PLOTTING
|
||
|
|
! CALL PLOTOT
|
||
|
|
NEFL=0
|
||
|
|
95 NHTP=7
|
||
|
|
NMESS=0
|
||
|
|
NBRR=0
|
||
|
|
CALL HEDR
|
||
|
|
100 CONTINUE
|
||
|
|
!
|
||
|
|
! Check out mouse
|
||
|
|
!
|
||
|
|
IBOX=1
|
||
|
|
CALL PROX(XC,YC,NE,XX,YY,IELEM,IFLAG,IESKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
! Return if quit called
|
||
|
|
!
|
||
|
|
IF(IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ELSEIF(IFLAG .EQ. 'c') THEN
|
||
|
|
GO TO 120
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
! Check for reading number
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'n') THEN
|
||
|
|
NHTP=0
|
||
|
|
NMESS=45
|
||
|
|
CALL HEDR
|
||
|
|
NMESS=20
|
||
|
|
CALL GETINT(IELEM)
|
||
|
|
NEFL=NEFL+1
|
||
|
|
NEFLAG(NEFL)=IELEM
|
||
|
|
CALL FILLEM(IELEM)
|
||
|
|
GO TO 95
|
||
|
|
!
|
||
|
|
! Check for selecting all elements
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 'a') THEN
|
||
|
|
DO I=1,NE
|
||
|
|
IF(IMAT(I) .GT. 0) THEN
|
||
|
|
IF(IMAT(I) .LT. 901 .or. imat(i) .gt. 903) THEN
|
||
|
|
NEFL=NEFL+1
|
||
|
|
NEFLAG(NEFL)=I
|
||
|
|
CALL FILLEM(I)
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
GO TO 95
|
||
|
|
!
|
||
|
|
! Check for only rectangles
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 'g') THEN
|
||
|
|
DO I=1,NE
|
||
|
|
IF(NCORN(I) .EQ. 8) THEN
|
||
|
|
NEFL=NEFL+1
|
||
|
|
NEFLAG(NEFL)=I
|
||
|
|
CALL FILLEM(I)
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
GO TO 95
|
||
|
|
!
|
||
|
|
! Check for only triangles
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 't') THEN
|
||
|
|
DO I=1,NE
|
||
|
|
IF(NCORN(I) .EQ. 6) THEN
|
||
|
|
NEFL=NEFL+1
|
||
|
|
NEFLAG(NEFL)=I
|
||
|
|
CALL FILLEM(I)
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
GO TO 95
|
||
|
|
!
|
||
|
|
! Check for only line elements
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 'l') THEN
|
||
|
|
DO I=1,NE
|
||
|
|
IF((NCORN(I) .LT. 6 .and. ncorn(i) .gt. 2) .and. &
|
||
|
|
(imat(i) .lt. 901 .or. imat(i) .gt. 903)) THEN
|
||
|
|
NEFL=NEFL+1
|
||
|
|
NEFLAG(NEFL)=I
|
||
|
|
CALL FILLEM(I)
|
||
|
|
xa=(cord(nop(i,1),1)+cord(nop(i,3),1))/2.
|
||
|
|
ya=(cord(nop(i,1),2)+cord(nop(i,3),2))/2.
|
||
|
|
fpn=i
|
||
|
|
CALL NUMBR(xa,ya,0.18,FPN,0.0,-1)
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
GO TO 95
|
||
|
|
!
|
||
|
|
! Check for delete option
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 'd') THEN
|
||
|
|
CALL DELEL
|
||
|
|
!
|
||
|
|
! Check for refine option
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 'e') THEN
|
||
|
|
CALL REFB
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
! Check for help
|
||
|
|
!
|
||
|
|
ELSEIF (IFLAG .EQ. 'h') THEN
|
||
|
|
CALL HELPS(6)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 'U') THEN
|
||
|
|
NEFLAG(NEFL)=0
|
||
|
|
NEFL=NEFL-1
|
||
|
|
CALL PLOTOT(1)
|
||
|
|
CALL HEDR
|
||
|
|
DO IELEM=1,NEFL
|
||
|
|
CALL FILLEM(NEFLAG(IELEM))
|
||
|
|
ENDDO
|
||
|
|
GO TO 100
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
GO TO 2
|
||
|
|
120 NEFL=NEFL+1
|
||
|
|
NEFLAG(NEFL)=IELEM
|
||
|
|
CALL FILLEM(IELEM)
|
||
|
|
IF(NCORN(ielem) .LT. 6 .and. ncorn(ielem) .gt. 2) THEN
|
||
|
|
|
||
|
|
xa=(cord(nop(ielem,1),1)+cord(nop(ielem,3),1))/2.
|
||
|
|
ya=(cord(nop(ielem,1),2)+cord(nop(ielem,3),2))/2.
|
||
|
|
fpn=ielem
|
||
|
|
CALL NUMBR(xa,ya,0.18,FPN,0.0,-1)
|
||
|
|
endif
|
||
|
|
GO TO 100
|
||
|
|
END
|
||
|
|
!
|
||
|
|
!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
|
||
|
|
!
|
||
|
|
SUBROUTINE MKELEM
|
||
|
|
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
CHARACTER*1 IFLAG
|
||
|
|
CHARACTER*32 IJNK
|
||
|
|
CHARACTER*23 ELTH
|
||
|
|
!ipk jan98
|
||
|
|
CHARACTER*80 LIND
|
||
|
|
CHARACTER*60 MESSAGE,MESSAG1
|
||
|
|
!ipk jun96 add messag2
|
||
|
|
CHARACTER*26 MESSAG2
|
||
|
|
DATA MESSAG2/' Press return to continue'/
|
||
|
|
!ipkjul94 add a line
|
||
|
|
MEL=MAXE
|
||
|
|
!
|
||
|
|
! Form element nodal list by clicking on nodes with cursor
|
||
|
|
!
|
||
|
|
3 CONTINUE
|
||
|
|
CALL GETELM(J)
|
||
|
|
5 CONTINUE
|
||
|
|
IECHG=0
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
WRITE(ELTH,5000) j
|
||
|
|
5000 FORMAT('Processing element',i5)
|
||
|
|
CALL CLRBOX
|
||
|
|
!ipk jun96 clear a strip
|
||
|
|
call clrstp(7.2,7.5)
|
||
|
|
CALL SYMBL(0.,7.70,0.18,ELTH,0.,23)
|
||
|
|
XPRT=3.5
|
||
|
|
|
||
|
|
6 DO 10 K=1,10,2
|
||
|
|
!
|
||
|
|
! Find node nearest to cursor
|
||
|
|
!
|
||
|
|
7 CONTINUE
|
||
|
|
!ipk sep94 reset ibox
|
||
|
|
IBOX=1
|
||
|
|
!ipk sep49 add call to hedr
|
||
|
|
nhtp=0
|
||
|
|
!ipk jun96 nmess=22
|
||
|
|
nmess=15
|
||
|
|
nbrr=3
|
||
|
|
call hedr
|
||
|
|
! write(155,*) width(1),width(2),width(3)
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
! IF(IFLAG .EQ. 'z') THEN
|
||
|
|
! DO 62 I=1,NP
|
||
|
|
! IF(CORD(I,1) .GT. VOID) THEN
|
||
|
|
! INSKP(I)=0
|
||
|
|
! ENDIF
|
||
|
|
! 62 CONTINUE
|
||
|
|
! DO 63 I=1,NE
|
||
|
|
! IF(IMAT(I) .GT. 0) THEN
|
||
|
|
! IESKP(I)=0
|
||
|
|
! ENDIF
|
||
|
|
! 63 CONTINUE
|
||
|
|
CALL RBLUE
|
||
|
|
if(inode .lt. 1) return
|
||
|
|
CALL PLTNOD(INODE,1)
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. 9.6) then
|
||
|
|
XPRT=0.
|
||
|
|
!ipk jun96 clear a strip
|
||
|
|
call clrstp(7.2,7.5)
|
||
|
|
endif
|
||
|
|
FPN= INODE
|
||
|
|
CALL RBLUE
|
||
|
|
CALL NUMBR(XPRT,7.30,0.18,FPN,0.0,-1)
|
||
|
|
!
|
||
|
|
IF(K .EQ. 9) THEN
|
||
|
|
IF(IFLAG .EQ. 'm') THEN
|
||
|
|
NOP(J,K-1) = INODE
|
||
|
|
WD(INODE) = 0.
|
||
|
|
!
|
||
|
|
! Five node element
|
||
|
|
!
|
||
|
|
ELSEIF (IFLAG .EQ. 'f') THEN
|
||
|
|
NOP(J,4)=NOP(J,5)
|
||
|
|
NOP(J,5)=NOP(J,7)
|
||
|
|
NOP(J,7) = 0
|
||
|
|
NOP(J,8) = 0
|
||
|
|
ENDIF
|
||
|
|
GO TO 10
|
||
|
|
ENDIF
|
||
|
|
IF (IFLAG .NE. 'r') THEN
|
||
|
|
NOP(J,K) = 0
|
||
|
|
NOP(J,K+1) = 0
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
! Corner node
|
||
|
|
!
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
NOP(J,K) = INODE
|
||
|
|
!
|
||
|
|
! Midside node
|
||
|
|
!
|
||
|
|
ELSEIF (IFLAG .EQ. 'm') THEN
|
||
|
|
NOP(J,K-1) = INODE
|
||
|
|
GOTO 7
|
||
|
|
!
|
||
|
|
! Triangular element
|
||
|
|
!
|
||
|
|
ELSEIF (IFLAG .EQ. 't' .AND. K .EQ. 7) THEN
|
||
|
|
NOP(J,7) = 0
|
||
|
|
NOP(J,8) = 0
|
||
|
|
GOTO 20
|
||
|
|
!
|
||
|
|
! 1-d element
|
||
|
|
!
|
||
|
|
ELSEIF (IFLAG .EQ. 'l' .AND. K .EQ. 5) THEN
|
||
|
|
NOP(J,4) = 0
|
||
|
|
NOP(J,5) = 0
|
||
|
|
NOP(J,6) = 0
|
||
|
|
NOP(J,7) = 0
|
||
|
|
NOP(J,8) = 0
|
||
|
|
GOTO 20
|
||
|
|
!
|
||
|
|
! Junction element
|
||
|
|
!
|
||
|
|
ELSEIF (IFLAG .EQ. 'j' .AND. K .EQ. 3) THEN
|
||
|
|
INODE= NOP(J,1)
|
||
|
|
NOP(J,1)=0
|
||
|
|
CALL JUNGEN(J,INODE,IER)
|
||
|
|
IF(IER .EQ. 1) THEN
|
||
|
|
!
|
||
|
|
! Redo if error
|
||
|
|
!
|
||
|
|
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||
|
|
GOTO 7
|
||
|
|
ENDIF
|
||
|
|
GO TO 20
|
||
|
|
!
|
||
|
|
! Exit input
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
NE=NE-1
|
||
|
|
!ipkfeb94 CALL WRTOUT(0)
|
||
|
|
IRDONE=0
|
||
|
|
RETURN
|
||
|
|
!
|
||
|
|
! Redo if error
|
||
|
|
!
|
||
|
|
ELSE
|
||
|
|
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||
|
|
GOTO 6
|
||
|
|
ENDIF
|
||
|
|
10 END DO
|
||
|
|
!
|
||
|
|
20 IF (IMAT(J) .EQ. 0) IMAT(J) = 1
|
||
|
|
!
|
||
|
|
! rearrange if nop(j,4) .ne. 0 separate it from
|
||
|
|
! a transition element
|
||
|
|
!
|
||
|
|
IF(NOP(J,4) .NE. 0 .AND. NOP(J,6) .EQ. 0) THEN
|
||
|
|
IF(IFLAG .NE. 'f' .AND. IMAT(J) .LT. 901) THEN
|
||
|
|
|
||
|
|
ITMP1 = NOP(J,1)
|
||
|
|
ITMP2 = NOP(J,2)
|
||
|
|
DO 30 KK=1,6
|
||
|
|
NOP(J,KK) = NOP(J,KK+2)
|
||
|
|
30 CONTINUE
|
||
|
|
IF(NOP(J,5) .EQ. 0) THEN
|
||
|
|
NOP(J,5)=ITMP1
|
||
|
|
NOP(J,6)=ITMP2
|
||
|
|
ELSE
|
||
|
|
NOP(J,7)=ITMP1
|
||
|
|
NOP(J,8)=ITMP2
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
NCN = 2
|
||
|
|
IF (NOP(J,3) .NE. 0) NCN = 3
|
||
|
|
IF (NOP(J,4) .NE. 0) NCN = 4
|
||
|
|
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5
|
||
|
|
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6
|
||
|
|
IF (NOP(J,6) .NE. 0) NCN = 6
|
||
|
|
IF (NOP(J,7) .NE. 0) NCN = 8
|
||
|
|
!
|
||
|
|
! Check to see if duplicate node numbers have been defined
|
||
|
|
!
|
||
|
|
DO 40 KK=1,NCN-1
|
||
|
|
IF(NOP(J,KK) .EQ. 0) GO TO 40
|
||
|
|
DO 37 LL=KK+1,NCN
|
||
|
|
IF(NOP(J,KK) .EQ. NOP(J,LL)) THEN
|
||
|
|
WRITE(MESSAGE,6000) J
|
||
|
|
6000 FORMAT(' **ERROR** NODES AT ELEMENT NUMBER',I5,' ARE DUPLICATED RE&
|
||
|
|
&TRY')
|
||
|
|
WRITE(MESSAG1,6001) (NOP(J,II),II=1,8)
|
||
|
|
6001 FORMAT(' NODE LIST FOLLOWS ',8I5)
|
||
|
|
CALL CLRBOX
|
||
|
|
CALL SYMBL(0.,7.75,0.18,MESSAGE,0.,60)
|
||
|
|
CALL SYMBL(0.,7.55,0.18,MESSAG1,0.,60)
|
||
|
|
!IPK JUN96
|
||
|
|
CALL SYMBL(0.,7.35,0.18,MESSAG2,0.,25)
|
||
|
|
call keybrd(k)
|
||
|
|
!cc read(*,'(A)') ijnk
|
||
|
|
!ipk jun96 change transfer location
|
||
|
|
! GO TO 6
|
||
|
|
go to 5
|
||
|
|
ENDIF
|
||
|
|
37 CONTINUE
|
||
|
|
40 END DO
|
||
|
|
NCORN(J) = NCN
|
||
|
|
IESKP(J) = 0
|
||
|
|
NE = MAX(J,NE)
|
||
|
|
!IPK JAN98
|
||
|
|
IERC=0
|
||
|
|
CALL PLTELM(J,IERC)
|
||
|
|
!
|
||
|
|
! WRITE(IOT,'(10I5)') J, (NOP(J,K),K=1,8), IMAT(J)
|
||
|
|
!
|
||
|
|
! Return if dimensions exceeded
|
||
|
|
!
|
||
|
|
!ipk jul94 IF (J .GE. MAXE) THEN
|
||
|
|
IF (J .GE. MEL) THEN
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
CALL CLSCRN
|
||
|
|
!ipk jan98 CALL SETD(24)
|
||
|
|
!ipk jan98 WRITE(*,*) ' Element number exceeds MAXE. Press retur
|
||
|
|
WRITE(lind,*) &
|
||
|
|
& ' Element number exceeds MAXE. Press return to exit'
|
||
|
|
call symbl &
|
||
|
|
& (1.1,4.0,0.20,LIND,0.0,80)
|
||
|
|
!ipk jan98 READ(*,'(A)') IJNK
|
||
|
|
ndig=1
|
||
|
|
CALL GTCHARX(IJNK,NDIG,5.0,4.0)
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
! Go do another element
|
||
|
|
!
|
||
|
|
GOTO 3
|
||
|
|
|
||
|
|
!
|
||
|
|
END
|