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.
301 lines
7.5 KiB
Fortran
301 lines
7.5 KiB
Fortran
5 years ago
|
SUBROUTINE CONOUT(MENUS)
|
||
|
|
!
|
||
|
|
USE WINTERACTER
|
||
|
|
USE BLK1MOD
|
||
|
|
SAVE
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||
|
|
!
|
||
|
|
DIMENSION VALUS(MAXP)
|
||
|
|
|
||
|
|
CHARACTER*60 STRELS
|
||
|
|
|
||
|
|
DATA STRELS/' You have tried to reorder before executing "FILL"'/
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Test to make sure fill has been executed.
|
||
|
|
!
|
||
|
|
IF(MENUUS .EQ. 13) ifilltmp=0
|
||
|
|
DO N=1,NE
|
||
|
|
IF(IMAT(N) .GT. 0) THEN
|
||
|
|
DO M=2,NCORN(N),2
|
||
|
|
!ipkoct93
|
||
|
|
if(imat(n) .LT. 900) THEN
|
||
|
|
IF(NOP(N,M) .EQ. 0) THEN
|
||
|
|
CALL WMessageBox(YesNo,QuestionIcon,CommonOK,'You have tried to plot contours before filling'//char(13)//&
|
||
|
|
'Do you wish to temporarily fill and proceed?'//&
|
||
|
|
CHAR(13)//' ','PLOTTING CONTOURS WITHOUT A FILLED NETWORK?')
|
||
|
|
!
|
||
|
|
! If answer 'No', return
|
||
|
|
!
|
||
|
|
IF (WInfoDialog(4).EQ.2) THEN
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
CALL FILM(1)
|
||
|
|
ifilltmp=1
|
||
|
|
call hedr
|
||
|
|
GO TO 300
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
!
|
||
|
|
300 CONTINUE
|
||
|
|
DO N=1,NP
|
||
|
|
VALUS(N)=WD(N)
|
||
|
|
ENDDO
|
||
|
|
!
|
||
|
|
CALL TOLMAX(VALUS,TTMIN,TTMAX)
|
||
|
|
|
||
|
|
ISZ=0
|
||
|
|
IF(MENUS .EQ. 13) THEN
|
||
|
|
ISZ=1
|
||
|
|
CALL CSET(TTMIN,TTMAX,isz)
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
PSCL=1.0
|
||
|
|
CALL ELCONT(VALUS,PSCL)
|
||
|
|
|
||
|
|
if(ifilltmp .eq. 1) CALL DELETM(0)
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
SUBROUTINE ELCONT(VALUS,PSCL)
|
||
|
|
!
|
||
|
|
! Routine to draw element contours
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
INCLUDE 'BFILES.I90'
|
||
|
|
COMMON /BRK/ X(10),Y(10),VL(10),DL(10),VLM(10)
|
||
|
|
COMMON /OPTION/ SWITCH(4),NUMV,CONTUR(99),IQUAL,XCSQ,NUMCOL
|
||
|
|
LOGICAL SWITCH
|
||
|
|
! DIMENSION X(10),Y(10),VL(10),VALUS(*)
|
||
|
|
DIMENSION VALUS(*)
|
||
|
|
DATA PSCL1/1.0/ITIME/0/
|
||
|
|
|
||
|
|
IF(PSCL .eq. 0.) then
|
||
|
|
PSCL=PSCL1
|
||
|
|
ELSE
|
||
|
|
PSCL1=PSCL
|
||
|
|
ENDIF
|
||
|
|
CALL RRed
|
||
|
|
|
||
|
|
CALL GETXC
|
||
|
|
|
||
|
|
IF(.NOT. ALLOCATED(NKEY1)) THEN
|
||
|
|
ALLOCATE (NKEY1(MAXE))
|
||
|
|
ENDIF
|
||
|
|
CALL SORTDB(YC,NKEY1,NE)
|
||
|
|
|
||
|
|
DO 500 NN=NE,1,-1
|
||
|
|
N=NKEY1(NN)
|
||
|
|
IF(IESKP(N) .EQ. 1) GO TO 500
|
||
|
|
NCN=NCORN(N)
|
||
|
|
IF(NCN .EQ. 9) NCN=8
|
||
|
|
DO M=1,NCN,2
|
||
|
|
if(nop(n,m) .eq. 0) go to 500
|
||
|
|
IF(VALUS(NOP(N,M)) .LT. -9998.) GO TO 500
|
||
|
|
ENDDO
|
||
|
|
!
|
||
|
|
! Copy values into work array
|
||
|
|
!
|
||
|
|
NCN=NCORN(N)
|
||
|
|
! if(ncn .lt. 6) go to 500
|
||
|
|
IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) GO TO 500
|
||
|
|
IOK=0
|
||
|
|
DO 300 M=1,NCN
|
||
|
|
IF(NOP(N,M) .EQ. 0) GO TO 500
|
||
|
|
X(M)=CORD(NOP(N,M),1)
|
||
|
|
Y(M)=CORD(NOP(N,M),2)
|
||
|
|
IF(I3DVIEW .EQ. 1) THEN
|
||
|
|
IF(VRTSCAL .GT. 0.) THEN
|
||
|
|
Y(M)=Y(M)+(WD(NOP(N,M))-VRTORIG)*COS(VANG/57.29578)/VRTSCAL
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
IF(X(M) .GT. 0. .AND. X(M) .LT. HSIZE) THEN
|
||
|
|
IF(Y(M) .GT. 0. .AND. Y(M) .LT. 7.) THEN
|
||
|
|
IOK=1
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
VL(M)=VALUS(NOP(N,M))*PSCL
|
||
|
|
300 CONTINUE
|
||
|
|
IF(IOK .EQ. 0) GO TO 500
|
||
|
|
! CALL BRKDWN(X,Y,VL,NCN)
|
||
|
|
NELNO=N
|
||
|
|
CALL BRKDWN(NCN,NELNO)
|
||
|
|
|
||
|
|
!ipkoct93
|
||
|
|
if(ipsw(4) .eq. 1) then
|
||
|
|
NLINP=NCN+1
|
||
|
|
X(NLINP)=X(1)
|
||
|
|
Y(NLINP)=Y(1)
|
||
|
|
CALL DASHLN(X,Y,NLINP,0)
|
||
|
|
endif
|
||
|
|
|
||
|
|
500 CONTINUE
|
||
|
|
!
|
||
|
|
! Print title
|
||
|
|
!
|
||
|
|
ncharr=lenstr(title)
|
||
|
|
call rblue
|
||
|
|
IF(NCHARR .GT. 1) CALL SYMBL(0.5,7.25,0.20,TITLE,0.0,ncharr)
|
||
|
|
|
||
|
|
XLEG=8.8
|
||
|
|
YLEG=7.4
|
||
|
|
|
||
|
|
CALL LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL)
|
||
|
|
CALL RBlue
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE LEGND(XLEG,YLEG,CONTUR,NUMV,NUMCOL)
|
||
|
|
SAVE
|
||
|
|
DIMENSION CONTUR(99),X(10),Y(10)
|
||
|
|
DATA LDIGO/2/
|
||
|
|
XLOC=XLEG+0.5
|
||
|
|
YLOC=YLEG
|
||
|
|
csfact=1.0001
|
||
|
|
DO 80 N=1,NUMV
|
||
|
|
IF(N .LT. NUMV) THEN
|
||
|
|
!
|
||
|
|
! Define polygon
|
||
|
|
!
|
||
|
|
X(1)=XLEG
|
||
|
|
X(2)=XLEG
|
||
|
|
X(3)=XLEG+0.4
|
||
|
|
X(4)=XLEG+0.4
|
||
|
|
Y(1)=YLOC
|
||
|
|
Y(2)=YLOC-0.3
|
||
|
|
Y(3)=YLOC-0.3
|
||
|
|
Y(4)=YLOC
|
||
|
|
nn=(n+1)*csfact
|
||
|
|
if(numv .le. 10) nn=nn+2
|
||
|
|
CALL POLYG(X,Y,4,nn)
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
! Plot the value on the screen
|
||
|
|
!
|
||
|
|
if(contur(n) .ne. 0.) then
|
||
|
|
DIG = ALOG10(ABS(CONTUR(N)))
|
||
|
|
else
|
||
|
|
dig = -2.
|
||
|
|
endif
|
||
|
|
IF(DIG .GT. 2.999) THEN
|
||
|
|
LDIG=-DIG - 1
|
||
|
|
ELSEIF (DIG .GT. 1.999) THEN
|
||
|
|
LDIG = 0
|
||
|
|
ELSEIF (DIG .GT. 0.999) THEN
|
||
|
|
LDIG = 1
|
||
|
|
ELSEIF (DIG .GT. 0) THEN
|
||
|
|
LDIG = 2
|
||
|
|
ELSE
|
||
|
|
LDIG = DIG - 2. + .01
|
||
|
|
LDIG = -LDIG
|
||
|
|
ENDIF
|
||
|
|
IF(LDIG .LT. 0) GO TO 70
|
||
|
|
DO 60 KK=1,3
|
||
|
|
ANUM=10.**(-LDIG)
|
||
|
|
IF(N .EQ. 1) THEN
|
||
|
|
IF(ABS(CONTUR(2)-CONTUR(1)) .LT. ANUM) THEN
|
||
|
|
LDIG = LDIG + 1
|
||
|
|
ELSE
|
||
|
|
GO TO 70
|
||
|
|
ENDIF
|
||
|
|
ELSE
|
||
|
|
IF(ABS(CONTUR(N)-CONTUR(N-1)) .LT. ANUM) THEN
|
||
|
|
LDIG = LDIG + 1
|
||
|
|
ELSE
|
||
|
|
GO TO 70
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
60 CONTINUE
|
||
|
|
70 CONTINUE
|
||
|
|
call rblue
|
||
|
|
CTMP=CONTUR(N)
|
||
|
|
IF(ABS(CTMP) .LT. 1.E-7) THEN
|
||
|
|
CTMP=0.
|
||
|
|
LDIG=LDIGO
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
CALL rblack
|
||
|
|
CALL NUMBR(XLOC,YLOC-0.09,0.2,CTMP,0.0,LDIG)
|
||
|
|
LDIGO=LDIG
|
||
|
|
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)
|
||
|
|
!
|
||
|
|
YLOC=YLOC-0.30
|
||
|
|
80 CONTINUE
|
||
|
|
CALL RBlue
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
|
||
|
|
SUBROUTINE TOLMAX(VALUS,TTMIN,TTMAX)
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
|
||
|
|
DIMENSION VALUS(*)
|
||
|
|
!
|
||
|
|
TMAX = -1.E+20
|
||
|
|
TMIN = 1.E+20
|
||
|
|
DO 218 J=1,NP
|
||
|
|
IF (VALUS(J) .GT. TMAX) THEN
|
||
|
|
TMAX = VALUS(J)
|
||
|
|
ITMAX = J
|
||
|
|
ENDIF
|
||
|
|
IF (VALUS(J) .LT. TMIN) THEN
|
||
|
|
TMIN = VALUS(J)
|
||
|
|
ITMIN = J
|
||
|
|
ENDIF
|
||
|
|
218 CONTINUE
|
||
|
|
WRITE(90,*) ' '
|
||
|
|
WRITE(90,*) ' Max, Min for entire network '
|
||
|
|
WRITE(90,*) ' MAX value = ', TMAX, ' at node ', ITMAX
|
||
|
|
WRITE(90,*) ' MIN value = ', TMIN, ' at node ', ITMIN
|
||
|
|
WRITE(90,*) ' '
|
||
|
|
!
|
||
|
|
! Check for max and min values of elements in the plotting area
|
||
|
|
!
|
||
|
|
TTMAX = -1.E+20
|
||
|
|
TTMIN = 1.E+20
|
||
|
|
DO 228 N=1,NE
|
||
|
|
IF(IESKP(N) .EQ. 0) THEN
|
||
|
|
DO 220 M=1,NCORN(N)
|
||
|
|
J=NOP(N,M)
|
||
|
|
!ipk sep99
|
||
|
|
if(j .eq. 0) go to 220
|
||
|
|
IF (VALUS(J) .GT. TTMAX) THEN
|
||
|
|
TTMAX = VALUS(J)
|
||
|
|
ITTMAX = J
|
||
|
|
ENDIF
|
||
|
|
IF (VALUS(J) .LT. TTMIN) THEN
|
||
|
|
TTMIN = VALUS(J)
|
||
|
|
ITTMIN = J
|
||
|
|
ENDIF
|
||
|
|
220 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
228 CONTINUE
|
||
|
|
!
|
||
|
|
WRITE(90,*) ' '
|
||
|
|
WRITE(90,*) ' Max, Min for plot area '
|
||
|
|
WRITE(90,*) ' MAX value = ', TTMAX, ' at node ', ITTMAX
|
||
|
|
WRITE(90,*) ' MIN value = ', TTMIN, ' at node ', ITTMIN
|
||
|
|
!
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
|