! 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