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.
1270 lines
47 KiB
Fortran
1270 lines
47 KiB
Fortran
5 years ago
|
!IPK LAST UPDATE SEP 23 2015 ADD TESTING FOR CHNAGED ELEMENTS/NODES
|
||
|
|
!ipk last update Jan25 2001 fix when deleting center-mid expand ipsw
|
||
|
|
! last change ipk 12 July 1999
|
||
|
|
! Last change: IPK 13 Jan 98 10:01 am
|
||
|
|
!ipk last update Nov 18 1997
|
||
|
|
!ipk last updated Oct 23 1996
|
||
|
|
!ipk last updated June 23 1996
|
||
|
|
!ipk last updated Oct 25 1995
|
||
|
|
SUBROUTINE GETELM(NEM)
|
||
|
|
!
|
||
|
|
! Routine to find first free element number
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
DO 200 J=NELAST,NE
|
||
|
|
IF(IMAT(J) .EQ. 0) THEN
|
||
|
|
NEM=J
|
||
|
|
NELAST=J
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
200 END DO
|
||
|
|
NE=NE+1
|
||
|
|
NELAST=NE
|
||
|
|
NEM=NE
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
!
|
||
|
|
SUBROUTINE GETNOD(NPT)
|
||
|
|
!
|
||
|
|
! Routine to find first free node number
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
IF(NP .GT. 0) THEN
|
||
|
|
DO 200 J=NPLAST,NP
|
||
|
|
IF(INEW(J) .EQ. 0) THEN
|
||
|
|
NPT=J
|
||
|
|
NPLAST=J
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
200 END DO
|
||
|
|
ELSE
|
||
|
|
NP=0
|
||
|
|
ENDIF
|
||
|
|
NP=NP+1
|
||
|
|
NPLAST=NP
|
||
|
|
NPT=NP
|
||
|
|
IF(NPT .GT. MAXP) THEN
|
||
|
|
CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Execution terminated, nodal limits exceeded. Backup written','LIMITS EXCEEDED')
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
STOP
|
||
|
|
ENDIF
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!
|
||
|
|
!***********************************************************************
|
||
|
|
!
|
||
|
|
SUBROUTINE DELETN(J)
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
! Search for elements that attach to node J and remove them
|
||
|
|
!
|
||
|
|
DO 200 N=1,NE
|
||
|
|
IF(IMAT(N) .GT. 0) THEN
|
||
|
|
NCN=NCORN(N)
|
||
|
|
DO 180 K=1,NCN
|
||
|
|
IF(NOP(N,K) .EQ. J) THEN
|
||
|
|
!IPK APR94
|
||
|
|
IF(IMAT(N) .LT. 901 .OR. IMAT(N) .GT. 903) THEN
|
||
|
|
IF(MOD(K,2) .EQ. 0) THEN
|
||
|
|
IF(NCN .NE. 2) THEN
|
||
|
|
IF(NCN .NE. 5 .OR. K .EQ. 2) THEN
|
||
|
|
NOP(N,K)=0
|
||
|
|
GO TO 200
|
||
|
|
ENDIF
|
||
|
|
!IPK APR94 END CHANGES
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
IMAT(N)=0
|
||
|
|
XC(N)=VOID
|
||
|
|
YC(N)=VOID
|
||
|
|
NCORN(N)=0.
|
||
|
|
IF(N .LT. NELAST) NELAST=N
|
||
|
|
DO 170 KK=1,8
|
||
|
|
NOP(N,KK)=0
|
||
|
|
170 CONTINUE
|
||
|
|
IESKP(N)=1
|
||
|
|
GO TO 200
|
||
|
|
ENDIF
|
||
|
|
180 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
200 END DO
|
||
|
|
|
||
|
|
|
||
|
|
!IPK FEB08 TEST FOR LOWERING NE
|
||
|
|
DO N=NE,1,-1
|
||
|
|
IF(IMAT(N) .NE. 0) THEN
|
||
|
|
JJ=N
|
||
|
|
GO TO 225
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
225 NE=JJ
|
||
|
|
|
||
|
|
!
|
||
|
|
! Remove node now
|
||
|
|
!
|
||
|
|
CORD(J,1)=VOID
|
||
|
|
CORD(J,2)=VOID
|
||
|
|
XUSR(J) = VOID
|
||
|
|
YUSR(J) = VOID
|
||
|
|
INSKP(J)=1
|
||
|
|
INEW(J) = 0
|
||
|
|
WD(J)=-9999.
|
||
|
|
WIDTH(J)=0.
|
||
|
|
SS1(J)=0.
|
||
|
|
SS2(J)=0.
|
||
|
|
WIDS(J)=0.
|
||
|
|
IF(NPLAST .GT. J) NPLAST=J
|
||
|
|
!IPK FEB08 TEST FOR LOWERING NE
|
||
|
|
IF(J .EQ. NP) THEN
|
||
|
|
DO N=NP,1,-1
|
||
|
|
IF(INEW(N) .NE. 0) THEN
|
||
|
|
JJ=N
|
||
|
|
GO TO 250
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
250 NP=JJ
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!
|
||
|
|
!
|
||
|
|
!***********************************************************************
|
||
|
|
|
||
|
|
function lenstr(str)
|
||
|
|
!
|
||
|
|
! Find length of string (position of last non-blank character)
|
||
|
|
!
|
||
|
|
character*(*) str
|
||
|
|
|
||
|
|
n = len(str)
|
||
|
|
lenstr = n
|
||
|
|
do 10 i=0,n-1
|
||
|
|
idx = n-i
|
||
|
|
if (str(idx:idx) .ne. ' ') then
|
||
|
|
lenstr = idx
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
10 continue
|
||
|
|
return
|
||
|
|
END
|
||
|
|
!
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
subroutine prox(x,y,npts,xx,yy,ipt,iflag,inskp,ibox)
|
||
|
|
! x=array of x node locations
|
||
|
|
! y=array of y node location
|
||
|
|
! npts= max number of nodes
|
||
|
|
! xx=x screen lpcation
|
||
|
|
! yy=y screen location
|
||
|
|
! iflag=character flag
|
||
|
|
! inskp=array telling nodes to skip
|
||
|
|
! ibox=any box checked
|
||
|
|
save
|
||
|
|
CHARACTER*80 TITLE
|
||
|
|
CHARACTER*24 HLABL
|
||
|
|
CHARACTER*1 ALABL(10)
|
||
|
|
CHARACTER*40 MPDUM
|
||
|
|
COMMON /BLKA1/ TITLE,HLABL,ALABL &
|
||
|
|
& ,MPDUM
|
||
|
|
!ipk oct 95 lines defining MPDUM added
|
||
|
|
!
|
||
|
|
!ipk jan01 expand IPSW
|
||
|
|
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||
|
|
!
|
||
|
|
integer*2 inskp(*)
|
||
|
|
!IPK MAY02
|
||
|
|
REAL*8 x(*),y(*)
|
||
|
|
character*1 iflag
|
||
|
|
!
|
||
|
|
! if(ibox .eq. 0) then
|
||
|
|
! nbx=2
|
||
|
|
! call boxr(nbx)
|
||
|
|
! endif
|
||
|
|
!
|
||
|
|
! Get location of cursor
|
||
|
|
!
|
||
|
|
10 call xyloc(xscrn,yscrn,iflag,ibox)
|
||
|
|
! write(90,*) 'ibox,xscrn,yscrn',ibox,xscrn,yscrn,irmain
|
||
|
|
! write(90,7893) iflag
|
||
|
|
7893 format(' iflag',a2)
|
||
|
|
! read(*,*) junk
|
||
|
|
if(irmain .eq. 1) return
|
||
|
|
if(ibox .eq. 10) then
|
||
|
|
iflag = 'q'
|
||
|
|
return
|
||
|
|
elseif(ibox .eq. 9) then
|
||
|
|
iflag = 'r'
|
||
|
|
! elseif(ibox .eq. 7) then
|
||
|
|
! iflag = 'a'
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
!
|
||
|
|
if (iflag .eq. 'q') then
|
||
|
|
return
|
||
|
|
elseif(iflag .eq. 'r') then
|
||
|
|
return
|
||
|
|
elseif(iflag .ne. 'c') then
|
||
|
|
|
||
|
|
ibox=0
|
||
|
|
if(iflag .eq. 't') return
|
||
|
|
if(iflag .eq. 'l') return
|
||
|
|
if(iflag .eq. 'f') return
|
||
|
|
if(iflag .eq. 'e') return
|
||
|
|
if(iflag .eq. 'a') return
|
||
|
|
if(iflag .eq. 'j') return
|
||
|
|
if(iflag .eq. 'z') return
|
||
|
|
if(iflag .eq. 'n') return
|
||
|
|
if(iflag .eq. 'g') return
|
||
|
|
if(iflag .eq. 'h') return
|
||
|
|
!ipk oct96 add line below
|
||
|
|
if(iflag .eq. 'b') return
|
||
|
|
if(iflag .eq. 'U') return
|
||
|
|
!
|
||
|
|
if(iflag .eq. 'm') go to 12
|
||
|
|
!ipk jan98 write(*,*) char(7),char(7)
|
||
|
|
go to 10
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
! Compare to coordinates
|
||
|
|
12 d = 1.E+20
|
||
|
|
do 20 i=1,npts
|
||
|
|
!! write(*,*) 'i,npts',i,npts,inskp(i),x(i),y(i)
|
||
|
|
if(inskp(i) .ne. 0) go to 20
|
||
|
|
dist = sqrt( (xscrn-x(i))**2 + (yscrn-y(i))**2)
|
||
|
|
if (dist .lt. d) then
|
||
|
|
d = dist
|
||
|
|
ipt = i
|
||
|
|
xx = x(i)
|
||
|
|
yy = y(i)
|
||
|
|
endif
|
||
|
|
20 continue
|
||
|
|
return
|
||
|
|
!
|
||
|
|
!
|
||
|
|
END
|
||
|
|
!***********************************************************
|
||
|
|
subroutine zoom
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
dimension xot(5),yot(5)
|
||
|
|
character*1 iflag,ans
|
||
|
|
!
|
||
|
|
!ipk jun96 add zoomj
|
||
|
|
character*36 zoomh,zoomj,IFLAG32
|
||
|
|
character*22 zoomi
|
||
|
|
!ipk jan98
|
||
|
|
CHARACTER*80 lind
|
||
|
|
data zoomh/' Zooming, click at diagonal corners'/
|
||
|
|
data zoomi/' Click left if size OK'/
|
||
|
|
!ipk jun96 add zoomj
|
||
|
|
data zoomj/' Double click, click second point '/
|
||
|
|
!
|
||
|
|
!
|
||
|
|
80 CALL CLRBOX
|
||
|
|
CALL SYMBL(0.,7.70,0.20,zoomh,0.,36)
|
||
|
|
|
||
|
|
!jan09 xcc = 5.00
|
||
|
|
xcc = 5.00*hsize/10.
|
||
|
|
ycc = 3.5
|
||
|
|
!
|
||
|
|
100 continue
|
||
|
|
!
|
||
|
|
! Get cursor location
|
||
|
|
!
|
||
|
|
CALL XYLOC(xscrn,yscrn,iflag,ibox)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
!
|
||
|
|
if (iflag .eq. 'q') return
|
||
|
|
!
|
||
|
|
xp = xmin + xscrn
|
||
|
|
yp = ymin + yscrn
|
||
|
|
if(iflag .eq. 'c') then
|
||
|
|
!
|
||
|
|
! This option is creating an inset window
|
||
|
|
!
|
||
|
|
!ipk jun96 add new path
|
||
|
|
120 continue
|
||
|
|
CALL XYLOC(xscrn1,yscrn1,iflag,ibox)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
if(iflag .eq. 'c') then
|
||
|
|
!
|
||
|
|
! Look for a screen size
|
||
|
|
!
|
||
|
|
xsiz=abs(xscrn1-xscrn)
|
||
|
|
ysiz=abs(yscrn1-yscrn)
|
||
|
|
!ipk jun96 test for zero sizes
|
||
|
|
if(xsiz .lt. 0.001 .or. ysiz .lt. 0.001) then
|
||
|
|
CALL CLRBOX
|
||
|
|
CALL SYMBL(0.,7.70,0.20,zoomj,0.,36)
|
||
|
|
go to 120
|
||
|
|
endif
|
||
|
|
if(xscrn1 .lt. xscrn) xscrn=xscrn1
|
||
|
|
if(yscrn1 .lt. yscrn) yscrn=yscrn1
|
||
|
|
fact=HSIZE/xsiz
|
||
|
|
!jan09 if(7./ysiz .lt. fact) fact=7./ysiz
|
||
|
|
if(7.5/ysiz .lt. fact) fact=7.5/ysiz
|
||
|
|
xot(1)=xscrn
|
||
|
|
xot(5)=xscrn
|
||
|
|
yot(1)=yscrn
|
||
|
|
yot(5)=yscrn
|
||
|
|
yot(2)=yscrn
|
||
|
|
xot(4)=xscrn
|
||
|
|
!jan09 xscrn=xscrn+5./fact
|
||
|
|
!jan09 yscrn=yscrn+3.5/fact
|
||
|
|
xscrn=xscrn+xcc/fact
|
||
|
|
yscrn=yscrn+3.75/fact
|
||
|
|
!jan09 xot(2)=xscrn+5./fact
|
||
|
|
xot(2)=xscrn+xcc/fact
|
||
|
|
xot(3)=xot(2)
|
||
|
|
!jan09 yot(3)=yscrn+3.5/fact
|
||
|
|
yot(3)=yscrn+3.75/fact
|
||
|
|
yot(4)=yot(3)
|
||
|
|
call DASHLN(xot,yot,5,1)
|
||
|
|
xp=xscrn
|
||
|
|
yp=yscrn
|
||
|
|
CALL CLRBOX
|
||
|
|
CALL SYMBL(0.,7.70,0.20,zoomi,0.,22)
|
||
|
|
CALL XYLOC(xscrn1,yscrn1,iflag,ibox)
|
||
|
|
IF(IRMAIN .EQ. 1) RETURN
|
||
|
|
if(iflag .ne. 'c') go to 80
|
||
|
|
go to 280
|
||
|
|
!
|
||
|
|
! pan right
|
||
|
|
!
|
||
|
|
else if(iflag .eq. 'r') then
|
||
|
|
fact=1.0
|
||
|
|
!jan09 xscrn=xscrn+5.0
|
||
|
|
xscrn=xscrn+hsize/2.
|
||
|
|
xp=xscrn
|
||
|
|
yp=yscrn
|
||
|
|
!
|
||
|
|
! pan left
|
||
|
|
!
|
||
|
|
else if(iflag .eq. 'l') then
|
||
|
|
fact=1.0
|
||
|
|
!jan09 xscrn=xscrn-5.0
|
||
|
|
xscrn=xscrn-hsize/2.
|
||
|
|
xp=xscrn
|
||
|
|
yp=yscrn
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
! redraw at half size
|
||
|
|
!
|
||
|
|
elseif(iflag .eq. 'r') then
|
||
|
|
fact = 0.500
|
||
|
|
!
|
||
|
|
! user controlled redraw
|
||
|
|
!
|
||
|
|
else
|
||
|
|
call setd(23)
|
||
|
|
write (*,*) ' factor '
|
||
|
|
read(*,*) fact
|
||
|
|
call setd(2)
|
||
|
|
endif
|
||
|
|
do 250 i=1,np
|
||
|
|
if(cord(i,1) .gt. void) then
|
||
|
|
inskp(i)=0
|
||
|
|
endif
|
||
|
|
250 continue
|
||
|
|
do 270 i=1,ne
|
||
|
|
if(imat(i) .gt. 0) then
|
||
|
|
ieskp(i)=0
|
||
|
|
endif
|
||
|
|
270 continue
|
||
|
|
280 continue
|
||
|
|
pscale = pscale/fact
|
||
|
|
xmino=xmin
|
||
|
|
ymino=ymin
|
||
|
|
!
|
||
|
|
xmin = xp - (xcc*pscale)
|
||
|
|
ymin = yp - (ycc*pscale)
|
||
|
|
!
|
||
|
|
if(iflag .eq. 'c') then
|
||
|
|
! CALL PLOTS(0)
|
||
|
|
!ipk nov97 add (0)
|
||
|
|
CALL PLOTOT(0)
|
||
|
|
return
|
||
|
|
elseif(iflag .eq. 'r') then
|
||
|
|
! CALL PLOTS(0)
|
||
|
|
!ipk nov97 add (0)
|
||
|
|
CALL PLOTOT(0)
|
||
|
|
return
|
||
|
|
elseif(iflag .eq. 'l') then
|
||
|
|
! CALL PLOTS(0)
|
||
|
|
!ipk nov97 add (0)
|
||
|
|
CALL PLOTOT(0)
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
call setd(23)
|
||
|
|
write(lind,*) 'Illegal zoom press return to continue'
|
||
|
|
call symbl &
|
||
|
|
& (1.1,7.1,0.20,LIND,0.0,80)
|
||
|
|
ndig=1
|
||
|
|
CALL GTCHARX(IFLAG32,NDIG,5.0,7.6)
|
||
|
|
!ipk jan98 write(*,*) 'O.K. to plot at this scale? (y)es .or. (n)o'
|
||
|
|
!ipk jan98 write(*,*) 'Note n means redraw old plot'
|
||
|
|
!ipk jan98 read(*,'(a)') ans
|
||
|
|
!ipk jan98 call setd(2)
|
||
|
|
!ipk jan98 if (ans .eq. 'y') then
|
||
|
|
! CALL PLOTS(0)
|
||
|
|
!ipk nov97 add (0)
|
||
|
|
CALL PLOTOT(0)
|
||
|
|
return
|
||
|
|
!ipk jan98 endif
|
||
|
|
pscale = pscale * fact
|
||
|
|
xmin=xmino
|
||
|
|
ymin=ymino
|
||
|
|
! CALL PLOTS(0)
|
||
|
|
!ipk nov97 add (0)
|
||
|
|
CALL PLOTOT(0)
|
||
|
|
return
|
||
|
|
END
|
||
|
|
!***********************************************************
|
||
|
|
SUBROUTINE DELETM(ISW)
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
! COMMON /ICN1/ ICN(MAXP)
|
||
|
|
DIST(N1,N2)=SQRT((CORD(N1,1)-CORD(N2,1))**2 &
|
||
|
|
& +(CORD(N1,2)-CORD(N2,2))**2)
|
||
|
|
DO 150 J=1,MAXP
|
||
|
|
ICN(J)=0
|
||
|
|
150 END DO
|
||
|
|
IF(ISW .EQ. 2) GO TO 650
|
||
|
|
! First sort out the potential midsides
|
||
|
|
! Note that transition elements caues a problem
|
||
|
|
! Find these first
|
||
|
|
IRDONE=0
|
||
|
|
DO 200 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
|
||
|
|
if(imat(n) .eq. 0) then
|
||
|
|
ncorn(n)=0
|
||
|
|
go to 200
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
! 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 180 M=1,NCN,MST
|
||
|
|
ICN(NOP(N,M))=2
|
||
|
|
180 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
200 END DO
|
||
|
|
!
|
||
|
|
! test ISW
|
||
|
|
! if isw=0 then delete all midsides except at transition
|
||
|
|
! if isw=1 then delete only midsides that are truely in the middle
|
||
|
|
!
|
||
|
|
IF(ISW .EQ. 0) THEN
|
||
|
|
DO 400 N=1,NE
|
||
|
|
!IPKOCT93 IF(IMAT(N) .LT. 901) THEN
|
||
|
|
IF(IMAT(N) .LT. 901 .OR. IMAT(N) .GT. 903) THEN
|
||
|
|
IF(NCORN(N) .EQ. 5) THEN
|
||
|
|
NCN=3
|
||
|
|
ELSE
|
||
|
|
NCN=NCORN(N)
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
DO 350 M=2,NCN,2
|
||
|
|
J=NOP(N,M)
|
||
|
|
!SEP93 IPK
|
||
|
|
IF(J .EQ. 0) GO TO 350
|
||
|
|
!SEP93 IPK
|
||
|
|
IF(ICN(J) .NE. 1) THEN
|
||
|
|
NOP(N,M)=0
|
||
|
|
IF(ICN(J) .EQ. 0) THEN
|
||
|
|
!
|
||
|
|
! Remove node now
|
||
|
|
!
|
||
|
|
CORD(J,1)=VOID
|
||
|
|
CORD(J,2)=VOID
|
||
|
|
XUSR(J) = VOID
|
||
|
|
YUSR(J) = VOID
|
||
|
|
INSKP(J)=1
|
||
|
|
INEW(J) = 0
|
||
|
|
WD(J)=-9999.
|
||
|
|
WIDTH(J)=0.
|
||
|
|
SS1(J)=0.
|
||
|
|
SS2(J)=0.
|
||
|
|
WIDS(J)=0.
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
IF(NPLAST .GT. J) NPLAST=J
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
350 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
400 CONTINUE
|
||
|
|
ELSE
|
||
|
|
DO 600 N=1,NE
|
||
|
|
IF(IMAT(N) .LT. 901) THEN
|
||
|
|
IF(NCORN(N) .EQ. 5) THEN
|
||
|
|
NCN=3
|
||
|
|
ELSE
|
||
|
|
NCN=NCORN(N)
|
||
|
|
ENDIF
|
||
|
|
DO 550 M=2,NCN,2
|
||
|
|
J1=M-1
|
||
|
|
IF(M .EQ. NCN) THEN
|
||
|
|
J2=1
|
||
|
|
ELSE
|
||
|
|
J2=M+1
|
||
|
|
ENDIF
|
||
|
|
J=NOP(N,M)
|
||
|
|
!ipk jul99
|
||
|
|
if(j .gt. 0) then
|
||
|
|
!ipk jan01
|
||
|
|
IF(INEW(J) .EQ. 0 .or. inew(j) .eq. 2) THEN
|
||
|
|
inew(j)=0
|
||
|
|
NOP(N,M)=0
|
||
|
|
GO TO 550
|
||
|
|
ENDIF
|
||
|
|
else
|
||
|
|
go to 550
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
! Test for distance separation of midside node
|
||
|
|
!
|
||
|
|
XMID=(CORD(NOP(N,J1),1)+CORD(NOP(N,J2),1))/2.
|
||
|
|
YMID=(CORD(NOP(N,J1),2)+CORD(NOP(N,J2),2))/2.
|
||
|
|
DM=SQRT((XMID-CORD(J,1))**2+(YMID-CORD(J,2))**2)
|
||
|
|
DL=DIST(J1,J2)
|
||
|
|
IF(DM .LT. 0.005*DL) THEN
|
||
|
|
IF(ICN(J) .NE. 1) THEN
|
||
|
|
NOP(N,M)=0
|
||
|
|
IF(ICN(J) .EQ. 0) THEN
|
||
|
|
!
|
||
|
|
! Remove node now
|
||
|
|
!
|
||
|
|
CORD(J,1)=VOID
|
||
|
|
CORD(J,2)=VOID
|
||
|
|
XUSR(J) = VOID
|
||
|
|
YUSR(J) = VOID
|
||
|
|
INSKP(J)=1
|
||
|
|
INEW(J) = 0
|
||
|
|
WD(J)=-9999.
|
||
|
|
WIDTH(J)=0.
|
||
|
|
SS1(J)=0.
|
||
|
|
SS2(J)=0.
|
||
|
|
WIDS(J)=0.
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
IF(NPLAST .GT. J) NPLAST=J
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
550 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
600 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
!IPK FEB08 RESET NP
|
||
|
|
|
||
|
|
DO J=NP,1,-1
|
||
|
|
IF(INEW(J) .NE. 0) THEN
|
||
|
|
JJ=J
|
||
|
|
GO TO 625
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
625 CONTINUE
|
||
|
|
NP=JJ
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
!-
|
||
|
|
!-.....FIND MISSING NODE NUMBERS.....
|
||
|
|
!-
|
||
|
|
650 CONTINUE
|
||
|
|
DO 700 I=1,MAXP
|
||
|
|
700 ICN(I) = 0
|
||
|
|
DO 725 J = 1, NE
|
||
|
|
IF( IMAT(J) .EQ. 0 ) GO TO 725
|
||
|
|
DO 720 K = 1, 8
|
||
|
|
IF( NOP(J,K) .LE. 0) GOTO 720
|
||
|
|
ICN(NOP(J,K))=999
|
||
|
|
720 CONTINUE
|
||
|
|
725 END DO
|
||
|
|
!
|
||
|
|
! Remove nodes
|
||
|
|
!
|
||
|
|
DO 800 J=1,NP
|
||
|
|
IF(ICN(J) .EQ. 0) THEN
|
||
|
|
CORD(J,1)=VOID
|
||
|
|
CORD(J,2)=VOID
|
||
|
|
XUSR(J) = VOID
|
||
|
|
YUSR(J) = VOID
|
||
|
|
INSKP(J)=1
|
||
|
|
INEW(J) = 0
|
||
|
|
WD(J)=-9999.
|
||
|
|
WIDTH(J)=0.
|
||
|
|
SS1(J)=0.
|
||
|
|
SS2(J)=0.
|
||
|
|
WIDS(J)=0.
|
||
|
|
IF(NPLAST .GT. J) NPLAST=J
|
||
|
|
!IPK MAY03
|
||
|
|
ICHG=0
|
||
|
|
ENDIF
|
||
|
|
800 END DO
|
||
|
|
|
||
|
|
!IPK FEB08 RESET NP
|
||
|
|
|
||
|
|
DO J=NP,1,-1
|
||
|
|
IF(INEW(J) .NE. 0) THEN
|
||
|
|
JJ=J
|
||
|
|
GO TO 900
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
900 CONTINUE
|
||
|
|
NP=JJ
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
subroutine prox2(x,y,npts,xx,yy,ipt,xx2,yy2,ipt2,iflag,inskp,ibox)
|
||
|
|
save
|
||
|
|
CHARACTER*80 TITLE
|
||
|
|
CHARACTER*24 HLABL
|
||
|
|
CHARACTER*1 ALABL(10)
|
||
|
|
CHARACTER*40 MPDUM
|
||
|
|
COMMON /BLKA1/ TITLE,HLABL,ALABL ,MPDUM
|
||
|
|
!ipk oct 95 lines defining MPDUM added
|
||
|
|
!
|
||
|
|
!ipk jan01 expand IPSW
|
||
|
|
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||
|
|
!
|
||
|
|
integer*2 inskp(*)
|
||
|
|
!IPK MAY02
|
||
|
|
REAL*8 x(*),y(*)
|
||
|
|
character*1 iflag
|
||
|
|
!
|
||
|
|
! if(ibox .eq. 0) then
|
||
|
|
! nbx=2
|
||
|
|
! call boxr(nbx)
|
||
|
|
! endif
|
||
|
|
!
|
||
|
|
! Get location of cursor
|
||
|
|
!
|
||
|
|
10 call xyloc(xscrn,yscrn,iflag,ibox)
|
||
|
|
if(irmain .eq. 1) return
|
||
|
|
if(ibox .eq. 10) then
|
||
|
|
iflag = 'q'
|
||
|
|
return
|
||
|
|
elseif(ibox .eq. 9) then
|
||
|
|
iflag = 'r'
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
!
|
||
|
|
if (iflag .eq. 'q') then
|
||
|
|
return
|
||
|
|
elseif(iflag .eq. 'r') then
|
||
|
|
return
|
||
|
|
elseif(iflag .ne. 'c') then
|
||
|
|
ibox=0
|
||
|
|
if(iflag .eq. 't') return
|
||
|
|
if(iflag .eq. 'l') return
|
||
|
|
if(iflag .eq. 'f') return
|
||
|
|
if(iflag .eq. 'e') return
|
||
|
|
if(iflag .eq. 'a') return
|
||
|
|
if(iflag .eq. 'j') return
|
||
|
|
if(iflag .eq. 'z') return
|
||
|
|
if(iflag .eq. 'n') return
|
||
|
|
if(iflag .eq. 'g') return
|
||
|
|
if(iflag .eq. 'h') return
|
||
|
|
!
|
||
|
|
if(iflag .eq. 'm') go to 12
|
||
|
|
!ipk jan98 write(*,*) char(7),char(7)
|
||
|
|
go to 10
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
! Compare to coordinates
|
||
|
|
!
|
||
|
|
ipt2=0
|
||
|
|
12 d = 1.E+20
|
||
|
|
do 20 i=1,npts
|
||
|
|
if(inskp(i) .ne. 0) go to 20
|
||
|
|
dist = sqrt( (xscrn-x(i))**2 + (yscrn-y(i))**2)
|
||
|
|
if (dist .lt. d) then
|
||
|
|
if(i .ne. ipt) then
|
||
|
|
xx2=x(i)
|
||
|
|
yy2=y(i)
|
||
|
|
ipt2=i
|
||
|
|
d = dist
|
||
|
|
go to 20
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
20 continue
|
||
|
|
return
|
||
|
|
!
|
||
|
|
END
|
||
|
|
SUBROUTINE CVF(FPN,IDEC,NUMSTR,NUMC)
|
||
|
|
!
|
||
|
|
! Routine to convert number to array and prepare for plotting
|
||
|
|
!
|
||
|
|
CHARACTER*36 NUMSTR
|
||
|
|
CHARACTER*36 FMT,FMT1
|
||
|
|
|
||
|
|
IF(FPN .NE. 0.) THEN
|
||
|
|
if(idec .eq. 1) then
|
||
|
|
NDIG = ALOG10(ABS(FPN)+0.05)
|
||
|
|
elseif(idec .eq. 2) then
|
||
|
|
NDIG = ALOG10(ABS(FPN)+0.005)
|
||
|
|
elseif(idec .eq. 3) then
|
||
|
|
NDIG = ALOG10(ABS(FPN)+0.0005)
|
||
|
|
else
|
||
|
|
NDIG = ALOG10(ABS(FPN)+0.50005)
|
||
|
|
endif
|
||
|
|
ELSE
|
||
|
|
NDIG = 0
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
! Check for Numbers than 10
|
||
|
|
!
|
||
|
|
IF(NDIG .LE. 0) THEN
|
||
|
|
!
|
||
|
|
! Check for negative numbers
|
||
|
|
!
|
||
|
|
IF(FPN .LT. 0.) THEN
|
||
|
|
!
|
||
|
|
! Check for integer plot
|
||
|
|
!
|
||
|
|
IF(IDEC .LT. 0) THEN
|
||
|
|
NUMC = 2
|
||
|
|
IF(FPN .EQ. 0) NUMC=1
|
||
|
|
ELSE
|
||
|
|
!
|
||
|
|
! This is a negative number less than 10
|
||
|
|
!
|
||
|
|
NUMC = IDEC+3
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
! Check for integer plot probably a zero
|
||
|
|
!
|
||
|
|
ELSEIF(IDEC .LT. 0) THEN
|
||
|
|
NUMC = 1
|
||
|
|
ELSE
|
||
|
|
!
|
||
|
|
! This is a positive number less than 1
|
||
|
|
!
|
||
|
|
NUMC = IDEC+2
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
! Now check numbers of magnitude greater than 1
|
||
|
|
!
|
||
|
|
ELSEIF(FPN .LT. 0.) THEN
|
||
|
|
!
|
||
|
|
! Check for integer plot. A negative number
|
||
|
|
!
|
||
|
|
IF(IDEC .LT. 0) THEN
|
||
|
|
NUMC = NDIG+2
|
||
|
|
ELSE
|
||
|
|
!
|
||
|
|
! This is a negative number smaller than -1.
|
||
|
|
!
|
||
|
|
NUMC = IDEC+NDIG+3
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
!
|
||
|
|
! Check for integer plot. A positive number
|
||
|
|
!
|
||
|
|
ELSEIF(IDEC .LT. 0) THEN
|
||
|
|
NUMC = NDIG+1
|
||
|
|
ELSE
|
||
|
|
!
|
||
|
|
! This is a positive number greater than 1.
|
||
|
|
!
|
||
|
|
NUMC = IDEC+NDIG+2
|
||
|
|
ENDIF
|
||
|
|
IF(IDEC .LT. 0) THEN
|
||
|
|
IF(FPN .LT. 0.) THEN
|
||
|
|
NUM = FPN-0.5
|
||
|
|
ELSE
|
||
|
|
NUM = FPN+0.5
|
||
|
|
ENDIF
|
||
|
|
WRITE(FMT,97) NUMC
|
||
|
|
WRITE(NUMSTR,FMT) NUM
|
||
|
|
97 FORMAT('(I',i1,')')
|
||
|
|
ELSE
|
||
|
|
!ipk mar95 fix bug that causes error when IDEC >12
|
||
|
|
if(idec .gt. 9) then
|
||
|
|
write(fmt1,99) numc,idec
|
||
|
|
99 format('(F',i2,'.',i2,')')
|
||
|
|
else
|
||
|
|
WRITE(FMT1,98) NUMC,IDEC
|
||
|
|
98 FORMAT('(F',i2,'.',i1,')')
|
||
|
|
endif
|
||
|
|
WRITE(NUMSTR,FMT1) FPN
|
||
|
|
ENDIF
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
!ipk oct96 routines below added
|
||
|
|
|
||
|
|
SUBROUTINE GTCHARX(DATA,NDIG,XLC,YLC)
|
||
|
|
COMMON /RECOD/ IRECD,TSPC
|
||
|
|
|
||
|
|
CHARACTER*32 DATA
|
||
|
|
if(irecd .eq. 2) then
|
||
|
|
read(91,'(A32)') DATA
|
||
|
|
CALL INTRVL(TA,0)
|
||
|
|
70 CALL INTRVL(TA,1)
|
||
|
|
IF(TA .LT. TSPC) GO TO 70
|
||
|
|
return
|
||
|
|
endif
|
||
|
|
|
||
|
|
80 CONTINUE
|
||
|
|
DO 90 I=1,NDIG
|
||
|
|
DATA(I:I)=' '
|
||
|
|
90 END DO
|
||
|
|
!
|
||
|
|
I = 1
|
||
|
|
10 CONTINUE
|
||
|
|
I = I+1
|
||
|
|
call keybrd(key)
|
||
|
|
IF (KEY .EQ. 8) THEN
|
||
|
|
I = I-2
|
||
|
|
xp=XLC+(i+1)*0.20
|
||
|
|
call drblk(xp,YLC+0.23,0.20,0.30,-11)
|
||
|
|
GO TO 10
|
||
|
|
ENDIF
|
||
|
|
IF(KEY .EQ. 13 .OR. I .EQ. ndig+2) GO TO 200
|
||
|
|
if(key .eq. 1072 .or. key .eq. 1075 .or. key .eq. 1077 .or.&
|
||
|
|
& key .eq. 1080) go to 200
|
||
|
|
DATA(I-1:I-1)=CHAR(KEY)
|
||
|
|
xp=XLC+i*0.20
|
||
|
|
call drblk(xp,YLC+0.23,0.20,0.30,-11)
|
||
|
|
call rblue
|
||
|
|
call symbl(xp,YLC,0.20,data(i-1:i-1),0.0,1)
|
||
|
|
100 CONTINUE
|
||
|
|
GO TO 10
|
||
|
|
200 CONTINUE
|
||
|
|
NDIG=I-2
|
||
|
|
call rblue
|
||
|
|
RETURN
|
||
|
|
!ipk mar94 add
|
||
|
|
END
|
||
|
|
SUBROUTINE DRBLK(XS,YS,XL,YL,ICOL)
|
||
|
|
DIMENSION X(4),Y(4)
|
||
|
|
X(1)=XS
|
||
|
|
X(2)=XS
|
||
|
|
X(3)=XS+XL
|
||
|
|
X(4)=XS+XL
|
||
|
|
Y(1)=YS
|
||
|
|
Y(2)=YS-YL
|
||
|
|
Y(3)=Y(2)
|
||
|
|
Y(4)=YS
|
||
|
|
! WRITE(90,*) 'GOING TO POLYFL',X,Y,ICOL
|
||
|
|
CALL POLYFL(X,Y,4,ICOL)
|
||
|
|
call rblue
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
SUBROUTINE GTFPNX(FPN,NDEC,NDIG,XLC,YLC)
|
||
|
|
CHARACTER*11 DATA
|
||
|
|
CHARACTER*30 MES
|
||
|
|
|
||
|
|
REAL HSIZE
|
||
|
|
COMMON /SSIZE/ HSIZE
|
||
|
|
|
||
|
|
DATA MES/'Error reading number, Reenter.'/
|
||
|
|
80 CONTINUE
|
||
|
|
DO 90 I=1,11
|
||
|
|
DATA(I:I)=' '
|
||
|
|
90 END DO
|
||
|
|
!
|
||
|
|
I = 1
|
||
|
|
NDEC=-2
|
||
|
|
10 CONTINUE
|
||
|
|
I = I+1
|
||
|
|
call keybrd(key)
|
||
|
|
! WRITE(90,*) 'BACK FROMKEYBRD',KEY,I
|
||
|
|
IF (KEY .EQ. 8) THEN
|
||
|
|
I = I-2
|
||
|
|
xp=xlc+(i+1)*0.20
|
||
|
|
call drblk(xp,ylc+0.23,0.20,0.30,13)
|
||
|
|
GO TO 10
|
||
|
|
ENDIF
|
||
|
|
IF(KEY .EQ. 46) THEN
|
||
|
|
NDEC=-1
|
||
|
|
ENDIF
|
||
|
|
IF(KEY .EQ. 13) GO TO 200
|
||
|
|
if(key .eq. 1072 .or. key .eq. 1075 .or. key .eq. 1077 .or.&
|
||
|
|
& key .eq. 1080) go to 200
|
||
|
|
IF(NDEC .GE. -1) NDEC=NDEC+1
|
||
|
|
DATA(I:I)=CHAR(KEY)
|
||
|
|
! WRITE(90,'(A)') ' GETTING CHAR',DATA(I:I)
|
||
|
|
xp=xlc+i*0.20
|
||
|
|
! WRITE(90,*) 'GOING TO DRBLK',XP,YLC
|
||
|
|
call drblk(xp,ylc+0.23,0.20,0.30,-11)
|
||
|
|
! WRITE(90,*) 'BACK FROM DRBLK'
|
||
|
|
call rblue
|
||
|
|
call symbl(xp,ylc,0.20,data(i:i),0.0,1)
|
||
|
|
100 CONTINUE
|
||
|
|
GO TO 10
|
||
|
|
200 CONTINUE
|
||
|
|
NDIG=I-2
|
||
|
|
READ(DATA,5000,ERR=300) FPN
|
||
|
|
5000 FORMAT(1X,F10.0)
|
||
|
|
call rblue
|
||
|
|
RETURN
|
||
|
|
300 CONTINUE
|
||
|
|
CALL SYMBL(3.0,1.73,0.20,MES,0.0,30)
|
||
|
|
GO TO 80
|
||
|
|
END
|
||
|
|
SUBROUTINE GTINTX(INUM,NDIG,XLC,YLC)
|
||
|
|
CHARACTER*11 DATA
|
||
|
|
CHARACTER*30 MES
|
||
|
|
DATA MES/'Error reading integer, Reenter'/
|
||
|
|
80 CONTINUE
|
||
|
|
DO 90 I=1,11
|
||
|
|
DATA(I:I)=' '
|
||
|
|
90 END DO
|
||
|
|
!
|
||
|
|
I = 1
|
||
|
|
10 CONTINUE
|
||
|
|
I = I+1
|
||
|
|
call keybrd(key)
|
||
|
|
IF (KEY .EQ. 8) THEN
|
||
|
|
I = I-2
|
||
|
|
xp=xlc+(i+1)*0.20
|
||
|
|
call drblk(xp,ylc+0.00,0.20,0.32,-11)
|
||
|
|
GO TO 10
|
||
|
|
ENDIF
|
||
|
|
IF(KEY .EQ. 13) GO TO 200
|
||
|
|
if(key .eq. 1072 .or. key .eq. 1075 .or. key .eq. 1077 .or.&
|
||
|
|
& key .eq. 1080) go to 200
|
||
|
|
DATA(I:I)=CHAR(KEY)
|
||
|
|
xp=xlc+i*0.20
|
||
|
|
call drblk(xp,ylc+0.00,0.20,0.32,-11)
|
||
|
|
call rblue
|
||
|
|
call symbl(xp,ylc-0.20,0.20,data(i:i),0.0,1)
|
||
|
|
100 CONTINUE
|
||
|
|
GO TO 10
|
||
|
|
200 CONTINUE
|
||
|
|
NDIG=I-2
|
||
|
|
READ(DATA,5000,ERR=300) INUM
|
||
|
|
5000 FORMAT(1X,I10)
|
||
|
|
call rblue
|
||
|
|
RETURN
|
||
|
|
300 CONTINUE
|
||
|
|
CALL SYMBL(3.0,1.73,0.20,MES,0.0,30)
|
||
|
|
GO TO 80
|
||
|
|
END
|
||
|
|
SUBROUTINE WRTBOX(IDELV)
|
||
|
|
dimension x(5),y(5)
|
||
|
|
CHARACTER*6 label
|
||
|
|
COMMON /SSIZE/ HSIZE
|
||
|
|
DATA label/'(e)lsw'/
|
||
|
|
!
|
||
|
|
! Draw box around selections with colour
|
||
|
|
!
|
||
|
|
Y(1)=7.5
|
||
|
|
Y(2)=7.5
|
||
|
|
Y(3)=7.995
|
||
|
|
Y(4)=7.995
|
||
|
|
Y(5)=7.5
|
||
|
|
X(1)=6.0*HSIZE/10.
|
||
|
|
X(2)=7.0*HSIZE/10.
|
||
|
|
X(3)=7.0*HSIZE/10.
|
||
|
|
X(4)=6.0*HSIZE/10.
|
||
|
|
X(5)=6.0*HSIZE/10.
|
||
|
|
IF(IDELV .EQ. 1) THEN
|
||
|
|
IBLK=12
|
||
|
|
ELSE
|
||
|
|
IBLK= 8
|
||
|
|
ENDIF
|
||
|
|
CALL POLYFL(X,Y,5,IBLK)
|
||
|
|
CALL RBLACK
|
||
|
|
CALL PLOTT(X(1),Y(1),3)
|
||
|
|
CALL PLOTT(X(2),Y(2),2)
|
||
|
|
CALL PLOTT(X(3),Y(3),2)
|
||
|
|
CALL PLOTT(X(4),Y(4),2)
|
||
|
|
CALL PLOTT(X(1),Y(1),2)
|
||
|
|
call symbl(6.02*hsize/10.,7.6,0.20,label,0.0,6)
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE UNDOACT
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE '!BLK1.COM'
|
||
|
|
|
||
|
|
! IF(NEUNDO .GT. 0) THEN
|
||
|
|
! DO N=1,NEUNDO
|
||
|
|
! J=IELDEL(N)
|
||
|
|
! CALL DELTEL(J)
|
||
|
|
! ENDDO
|
||
|
|
! ELSE
|
||
|
|
! RETURN
|
||
|
|
! ENDIF
|
||
|
|
IF(NPUNDO .GT. 0) THEN
|
||
|
|
DO N=1,NPUNDO
|
||
|
|
J=NODDEL(N)
|
||
|
|
if(j .gt. 0) CALL DELETN(J)
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
NPUNDO=0
|
||
|
|
NEUNDO=0
|
||
|
|
WRITE(90,*) 'NESAV,NEFSAV',NESAV,NEFSAV,NE,NENTRY
|
||
|
|
IF(NESAV .GT. 0) THEN
|
||
|
|
DO J=1,NESAV
|
||
|
|
DO K=1,8
|
||
|
|
NOP(J,K)=NOPSV(J,K)
|
||
|
|
ENDDO
|
||
|
|
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
|
||
|
|
NCORN(J) = NCN
|
||
|
|
IESKP(J) = 0
|
||
|
|
IMAT(J)=IMATSV(J)
|
||
|
|
ENDDO
|
||
|
|
NE=NESAV
|
||
|
|
ENDIF
|
||
|
|
NESAV=0
|
||
|
|
IF(NENTRY .GT. NEFSAV) THEN
|
||
|
|
IF(NEFSAV .GT. 0) THEN
|
||
|
|
DO N=1,NEFSAV
|
||
|
|
DO M=1,3
|
||
|
|
NEF(N,M)=NEFSV(N,M)
|
||
|
|
ENDDO
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
NENTRY=NEFSAV
|
||
|
|
ENDIF
|
||
|
|
NEFSAV=NENTRY
|
||
|
|
CALL PLOTOT(-1)
|
||
|
|
CALL HEDR
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE GETXC
|
||
|
|
|
||
|
|
USE BLK1MOD
|
||
|
|
|
||
|
|
DO J=1,NE
|
||
|
|
XXC=0.
|
||
|
|
YYC=0.
|
||
|
|
IF(IMAT(J) .EQ. 0) GO TO 50
|
||
|
|
NCN = NCORN(J)
|
||
|
|
IF(NCN .EQ. 9) THEN
|
||
|
|
NCNR=8
|
||
|
|
ELSE
|
||
|
|
NCNR=NCN
|
||
|
|
ENDIF
|
||
|
|
DO 25 K=1,NCNR
|
||
|
|
N = NOP(J,K)
|
||
|
|
!
|
||
|
|
IF (N .EQ. 0) GO TO 25
|
||
|
|
IF (CORD(N,1) .LT. VDX) GOTO 25
|
||
|
|
! !
|
||
|
|
IF (NCN .NE. 5 .OR. K .LT. 5) THEN
|
||
|
|
IF (MOD(K,2) .EQ. 1) THEN
|
||
|
|
XXC = XXC + CORD(N,1)
|
||
|
|
YYC = YYC + CORD(N,2)
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
25 END DO
|
||
|
|
|
||
|
|
IF (NCN .EQ. 3 .OR. NCN .EQ. 5) NCN = 4
|
||
|
|
IF(NCN .LT. 9) THEN
|
||
|
|
XC(J) = 2.*XXC/NCN
|
||
|
|
YC(J) = 2.*YYC/NCN
|
||
|
|
ELSE
|
||
|
|
XC(J)= CORD(NOP(J,9),1)
|
||
|
|
YC(J)= CORD(NOP(J,9),2)
|
||
|
|
ENDIF
|
||
|
|
50 CONTINUE
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE DELETEM
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLK1MOD
|
||
|
|
SAVE
|
||
|
|
|
||
|
|
! implicit none
|
||
|
|
|
||
|
|
include 'd.inc'
|
||
|
|
|
||
|
|
INCLUDE 'TXFRM.COM'
|
||
|
|
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
|
||
|
|
CHARACTER*1 IFLAG
|
||
|
|
CHARACTER*24 MESSAG
|
||
|
|
INTEGER NTYPR,ITIMETHRU
|
||
|
|
DATA MESSAG/'GET ELEMENT TYPE NUMBER '/
|
||
|
|
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
call wdialogload(IDD_GETINT)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
|
||
|
|
CALL WDialogSelect(IDD_GETINT)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
NFD=0
|
||
|
|
CALL WDialogPutString(IDF_STRING1,MESSAG)
|
||
|
|
CALL WDialogPutInteger(IDF_INTEGER1,NFD)
|
||
|
|
|
||
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
||
|
|
ierr=infoerror(1)
|
||
|
|
! Branch depending on type of message.
|
||
|
|
!
|
||
|
|
DO
|
||
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
||
|
|
|
||
|
|
CALL WDialogGetInteger(IDF_INTEGER1,NFD)
|
||
|
|
GO TO 200
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
200 CONTINUE
|
||
|
|
IF(NFD .EQ. 0) RETURN
|
||
|
|
! ASK FOR ELEMENT NUMBER
|
||
|
|
! LOOP ON ELEMENTS DROPPING ELEMENTS OF GIVEN TYPE
|
||
|
|
DO N=1,NE
|
||
|
|
IF(IMAT(N) .EQ. NFD) THEN
|
||
|
|
DO K=1,8
|
||
|
|
NOP(N,K)=0
|
||
|
|
ENDDO
|
||
|
|
IMAT(N)=0
|
||
|
|
NCORN(N)=0
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
!
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
subroutine proxel(x,y,npts,xx,yy,ipt,iflag,inskp,ibox,neac)
|
||
|
|
! x=array of x node locations
|
||
|
|
! y=array of y node location
|
||
|
|
! npts= max number of nodes
|
||
|
|
! xx=x screen lpcation
|
||
|
|
! yy=y screen location
|
||
|
|
! iflag=character flag
|
||
|
|
! inskp=array telling nodes to skip
|
||
|
|
! ibox=any box checked
|
||
|
|
save
|
||
|
|
CHARACTER*80 TITLE
|
||
|
|
CHARACTER*24 HLABL
|
||
|
|
CHARACTER*1 ALABL(10)
|
||
|
|
CHARACTER*40 MPDUM
|
||
|
|
COMMON /BLKA1/ TITLE,HLABL,ALABL &
|
||
|
|
& ,MPDUM
|
||
|
|
!ipk oct 95 lines defining MPDUM added
|
||
|
|
!
|
||
|
|
!ipk jan01 expand IPSW
|
||
|
|
COMMON /HEDS/ NP,NE,NHTP,NMESS,NBRR,IPSW(15),IRMAIN,ISCRN,icolon(12),IQSW(2),IRDISP,ntempin,igfgsw,igfgswb,ICRIN,IPW1,WIDEL,WIDSCL,itrianout
|
||
|
|
!
|
||
|
|
integer*2 inskp(*)
|
||
|
|
INTEGER neac(*)
|
||
|
|
!IPK MAY02
|
||
|
|
REAL*8 x(*),y(*)
|
||
|
|
character*1 iflag
|
||
|
|
!
|
||
|
|
! if(ibox .eq. 0) then
|
||
|
|
! nbx=2
|
||
|
|
! call boxr(nbx)
|
||
|
|
! endif
|
||
|
|
!
|
||
|
|
! Get location of cursor
|
||
|
|
!
|
||
|
|
10 call xyloc(xscrn,yscrn,iflag,ibox)
|
||
|
|
! write(90,*) 'ibox,xscrn,yscrn',ibox,xscrn,yscrn,irmain
|
||
|
|
! write(90,7893) iflag
|
||
|
|
7893 format(' iflag',a2)
|
||
|
|
! read(*,*) junk
|
||
|
|
if(irmain .eq. 1) return
|
||
|
|
if(ibox .eq. 10) then
|
||
|
|
iflag = 'q'
|
||
|
|
return
|
||
|
|
elseif(ibox .eq. 9) then
|
||
|
|
iflag = 'r'
|
||
|
|
! elseif(ibox .eq. 7) then
|
||
|
|
! iflag = 'a'
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
!
|
||
|
|
if (iflag .eq. 'q') then
|
||
|
|
return
|
||
|
|
elseif(iflag .eq. 'r') then
|
||
|
|
return
|
||
|
|
elseif(iflag .ne. 'c') then
|
||
|
|
|
||
|
|
ibox=0
|
||
|
|
if(iflag .eq. 't') return
|
||
|
|
if(iflag .eq. 'l') return
|
||
|
|
if(iflag .eq. 'f') return
|
||
|
|
if(iflag .eq. 'e') return
|
||
|
|
if(iflag .eq. 'a') return
|
||
|
|
if(iflag .eq. 'j') return
|
||
|
|
if(iflag .eq. 'z') return
|
||
|
|
if(iflag .eq. 'n') return
|
||
|
|
if(iflag .eq. 'g') return
|
||
|
|
if(iflag .eq. 'h') return
|
||
|
|
!ipk oct96 add line below
|
||
|
|
if(iflag .eq. 'b') return
|
||
|
|
if(iflag .eq. 'U') return
|
||
|
|
!
|
||
|
|
if(iflag .eq. 'm') go to 12
|
||
|
|
!ipk jan98 write(*,*) char(7),char(7)
|
||
|
|
go to 10
|
||
|
|
endif
|
||
|
|
!
|
||
|
|
! Compare to coordinates
|
||
|
|
12 d = 1.E+20
|
||
|
|
do ii=1,8
|
||
|
|
i=neac(ii)
|
||
|
|
if(neac(ii) .eq. 0) cycle
|
||
|
|
!! write(*,*) 'i,npts',i,npts,inskp(i),x(i),y(i)
|
||
|
|
if(inskp(i) .ne. 0) cycle
|
||
|
|
dist = sqrt( (xscrn-x(i))**2 + (yscrn-y(i))**2)
|
||
|
|
if (dist .lt. d) then
|
||
|
|
d = dist
|
||
|
|
ipt = i
|
||
|
|
xx = x(i)
|
||
|
|
yy = y(i)
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
return
|
||
|
|
!
|
||
|
|
!
|
||
|
|
END
|
||
|
|
|