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.
152 lines
3.7 KiB
Fortran
152 lines
3.7 KiB
Fortran
SUBROUTINE CGEN
|
|
|
|
! Routine to establish contour lines
|
|
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
DIMENSION XINT(2),YINT(2),CSEL(100)&
|
|
,X(5),Y(5),VALC(5)
|
|
COMMON /CCGEN/ XCLIN(4000,2),YCLIN(4000,2),ALIN(-4000:4000,2),IUSED(4000)
|
|
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
|
common itempel(5000)
|
|
|
|
! Set up contours to be developed
|
|
!
|
|
CALL TOLMAX(WD,TTMIN,TTMAX)
|
|
|
|
|
|
ISZ=1
|
|
CALL CSET(TTMIN,TTMAX,isz)
|
|
|
|
NCLIN=NUMV
|
|
|
|
DO N=1,NUMV
|
|
CSEL(N)=CONTUR(N)
|
|
ENDDO
|
|
|
|
! Loop through each contour then each element
|
|
|
|
DO J=1,NCLIN
|
|
|
|
ILIN=0
|
|
DO N=1,NE
|
|
IF(IMAT(N) .GT. 0 .AND. IMAT(N) .LT. 901 .AND. NCORN(N) .GT. 5) THEN
|
|
ISWT=0
|
|
NCNX=NCORN(N)/2
|
|
DO K=1,3
|
|
X(K)=XUSR(NOP(N,2*K-1))
|
|
Y(K)=YUSR(NOP(N,2*K-1))
|
|
VALC(K)=WD(NOP(N,2*K-1))
|
|
ENDDO
|
|
NCNXX=3
|
|
CALL CGENTR(N,ISWT,NCNXX,X,Y,VALC,CSEL(J),XINT,YINT)
|
|
IF(ISWT .GT. 0) THEN
|
|
ILIN=ILIN+1
|
|
DO K=1,2
|
|
XCLIN(ILIN,K)=XINT(K)
|
|
YCLIN(ILIN,K)=YINT(K)
|
|
ENDDO
|
|
itempel(ilin)=n
|
|
ENDIF
|
|
|
|
IF(NCNX .EQ. 4) THEN
|
|
ISWT=0
|
|
DO K=3,5
|
|
IF(K .LT. 5) THEN
|
|
KK=2*K-1
|
|
ELSE
|
|
KK=1
|
|
ENDIF
|
|
X(K-2)=XUSR(NOP(N,KK))
|
|
Y(K-2)=YUSR(NOP(N,KK))
|
|
VALC(K-2)=WD(NOP(N,KK))
|
|
ENDDO
|
|
CALL CGENTR(N,ISWT,NCNXX,X,Y,VALC,CSEL(J),XINT,YINT)
|
|
IF(ISWT .GT. 0) THEN
|
|
ILIN=ILIN+1
|
|
DO K=1,2
|
|
XCLIN(ILIN,K)=XINT(K)
|
|
YCLIN(ILIN,K)=YINT(K)
|
|
ENDDO
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
do k=1,ilin
|
|
write(199,'(2i5,4f15.3)') k,itempel(k),xclin(k,1),yclin(k,1),xclin(k,2),yclin(k,2)
|
|
enddo
|
|
|
|
! Join up points to form contour lines
|
|
|
|
IF(ILIN .GT. 0) CALL JLINE(ILIN,CSEL(J))
|
|
|
|
ENDDO
|
|
MAXPTS=MAXPTS+1
|
|
CMAP(MAXPTS,1) = VOID
|
|
CMAP(MAXPTS,2) = VOID
|
|
XMAP(MAXPTS) = VOID
|
|
YMAP(MAXPTS) = VOID
|
|
|
|
RETURN
|
|
|
|
END
|
|
|
|
SUBROUTINE CGENTR(N,ISWT,NCN,X,Y,VAL,CVAL,XINT,YINT)
|
|
|
|
! Routine to find line (if it exists) across element N
|
|
|
|
DIMENSION X(5),Y(5),VAL(5),XINT(2),YINT(2)
|
|
|
|
! Get the max and min
|
|
|
|
IF(NCN .EQ. 3) THEN
|
|
CMAX=MAX(VAL(1),VAL(2),VAL(3))
|
|
CMIN=MIN(VAL(1),VAL(2),VAL(3))
|
|
ELSE
|
|
CMAX=MAX(VAL(1),VAL(2),VAL(3),VAL(4))
|
|
CMIN=MIN(VAL(1),VAL(2),VAL(3),VAL(4))
|
|
ENDIF
|
|
|
|
! Test if there is a contour
|
|
|
|
IF(CVAL .LT. CMIN .OR. CVAL .GT. CMAX) THEN
|
|
|
|
! No then return
|
|
|
|
ISWT=0
|
|
RETURN
|
|
ELSE
|
|
|
|
! Yes, determine end locations
|
|
|
|
ISWT=1
|
|
ENDIF
|
|
|
|
! Find the line number that it crosses
|
|
|
|
X(NCN+1)=X(1)
|
|
Y(NCN+1)=Y(1)
|
|
VAL(NCN+1)=VAL(1)
|
|
|
|
DO K=1,NCN
|
|
IF(CVAL .GE. VAL(K) .AND. CVAL .LT. VAL(K+1)) THEN
|
|
FRAC=(CVAL-VAL(K))/(VAL(K+1)-VAL(K))
|
|
XINT(ISWT)=X(K)+FRAC*(X(K+1)-X(K))
|
|
YINT(ISWT)=Y(K)+FRAC*(Y(K+1)-Y(K))
|
|
write(199,'(2i5,4f12.4)') n,k,frac,cval,val(k),val(k+1)
|
|
ISWT=ISWT+1
|
|
ELSEIF(CVAL .LT. VAL(K) .AND. CVAL .GE. VAL(K+1)) THEN
|
|
FRAC=(VAL(K)-CVAL)/(VAL(K)-VAL(K+1))
|
|
XINT(ISWT)=X(K)+FRAC*(X(K+1)-X(K))
|
|
YINT(ISWT)=Y(K)+FRAC*(Y(K+1)-Y(K))
|
|
write(199,'(2i5,4f12.4)') n,k,frac,cval,val(k),val(k+1)
|
|
ISWT=ISWT+1
|
|
ENDIF
|
|
|
|
ENDDO
|
|
|
|
RETURN
|
|
END
|
|
|