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.
149 lines
4.0 KiB
Fortran
149 lines
4.0 KiB
Fortran
SUBROUTINE COMPWGT
|
|
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
! COMMON/ICN1/ ICN(MAXP)
|
|
|
|
DIST(X1,X2,Y1,Y2)=SQRT((X1-X2)**2+(Y1-Y2)**2)
|
|
|
|
DO J=1,MAXP
|
|
ICN(J)=0
|
|
END DO
|
|
! First sort out the potential midsides
|
|
! Note that transition elements caues a problem
|
|
! Find these first
|
|
DO 200 N=1,NE
|
|
if(NCORN(N) .GT. 5) GO TO 200
|
|
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))=IMAT(N)
|
|
ICN(NOP(N,4))=IMAT(N)
|
|
ICN(NOP(N,5))=IMAT(N)
|
|
ELSE
|
|
!
|
|
! 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
|
|
GO TO 185
|
|
ELSE
|
|
MST=2
|
|
ENDIF
|
|
|
|
DO 180 M=1,NCN,MST
|
|
ICN(NOP(N,M))=IMAT(N)
|
|
180 CONTINUE
|
|
185 CONTINUE
|
|
ENDIF
|
|
200 END DO
|
|
|
|
DO N=1,NP
|
|
IF(ICN(N) .GT. 0) THEN
|
|
ADIST=1.E20
|
|
DO J=1,NCRSEC
|
|
IF(IVMIL(J) .EQ. 0) CYCLE
|
|
IF(ICN(N) .EQ. NOREACH(IVMIL(J))) THEN
|
|
A1=DIST(XUSR(N),XCRS(IVMIL(J)),YUSR(N),YCRS(IVMIL(J)))
|
|
IF(A1 .LT. ADIST) THEN
|
|
ADIST=A1
|
|
NSEC1=IVMIL(J)
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
!IPK JUN04
|
|
IF(ADIST .EQ. 1.E20) THEN
|
|
NRIVCR1(N)=0
|
|
NRIVCR2(N)=0
|
|
WTRIVCR1(N)=0
|
|
WTRIVCR2(N)=0
|
|
ELSE
|
|
BDIST=1.E20
|
|
DO J=1,NCRSEC
|
|
IF(IVMIL(J) .EQ. 0) CYCLE
|
|
IF(ICN(N) .EQ. NOREACH(IVMIL(J))) THEN
|
|
IF(IVMIL(J) .NE. NSEC1) THEN
|
|
A1=DIST(XUSR(N),XCRS(IVMIL(J)),YUSR(N),YCRS(IVMIL(J)))
|
|
A2=DIST(XCRS(NSEC1),XCRS(IVMIL(J)),YCRS(NSEC1),YCRS(IVMIL(J)))
|
|
|
|
! A1 IS DISTANCE TO NODE
|
|
! A2 IS DISTANCE TO RECORDED POINT
|
|
|
|
IF(A2 .GE. A1) THEN
|
|
IF(A1 .LT. BDIST) THEN
|
|
BDIST=A1
|
|
NSEC2=IVMIL(J)
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
IF(BDIST .EQ. 1.E20) NSEC2=NSEC1
|
|
NRIVCR1(N)=NSEC1
|
|
NRIVCR2(N)=NSEC2
|
|
WTRIVCR1(N)=BDIST/(ADIST+BDIST)
|
|
WTRIVCR2(N)=ADIST/(ADIST+BDIST)
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
RETURN
|
|
END
|
|
|
|
SUBROUTINE GETCSLOC
|
|
use winteracter
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
INCLUDE 'TXFRM.COM'
|
|
!-
|
|
|
|
include 'd.inc'
|
|
|
|
!
|
|
! Declare window-type and message variables
|
|
!
|
|
TYPE(WIN_STYLE) :: WINDOW
|
|
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
|
INTEGER :: IERR,ISET,IBOX
|
|
REAL :: ASET
|
|
CHARACTER*1 :: IFLAG
|
|
|
|
call wdialogload(IDD_CSLOC)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogSelect(IDD_CSLOC)
|
|
ierr=infoerror(1)
|
|
|
|
ISET=1
|
|
100 continue
|
|
|
|
|
|
CALL WDialogPutINTEGER(IDF_INTEGER1,ISET)
|
|
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
|
ierr=infoerror(1)
|
|
|
|
DO
|
|
!
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
|
|
|
|
|
CALL WDialogGetINTEGER(IDF_INTEGER1,ISET)
|
|
GO TO 200
|
|
else
|
|
RETURN
|
|
endif
|
|
ENDDO
|
|
200 CONTINUE
|
|
|
|
CALL XYLOC(XX,YY,IFLAG,IBOX)
|
|
IF(IRMAIN .EQ. 1) RETURN
|
|
XCRS(ISET) = XX*TXSCAL - XS
|
|
YCRS(ISET) = YY*TXSCAL - YS
|
|
GO TO 100
|
|
|
|
RETURN
|
|
END |