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.
344 lines
10 KiB
Fortran
344 lines
10 KiB
Fortran
5 years ago
|
! Last change: IPK 12 Jan 98 11:21 am
|
||
|
|
!
|
||
|
|
!****************************************************************
|
||
|
|
!
|
||
|
|
SUBROUTINE ADDLAY
|
||
|
|
!
|
||
|
|
! Add nodal layer data and write to file
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
!
|
||
|
|
CHARACTER*1 IFLAG,ANSW(10)
|
||
|
|
REAL RLAY(9)
|
||
|
|
DATA ANSW/' ',' ',' ',' ',' ',' ','n','z','r','q'/
|
||
|
|
!
|
||
|
|
4 CONTINUE
|
||
|
|
|
||
|
|
call openlay
|
||
|
|
|
||
|
|
NHTP=0
|
||
|
|
NBRR=0
|
||
|
|
NMESS=45
|
||
|
|
CALL HEDR
|
||
|
|
NMESS=4
|
||
|
|
xprt=3.2
|
||
|
|
!
|
||
|
|
IPOS=ILAYTP
|
||
|
|
call GETLAYDAT(NLAY,ipos,RLAY)
|
||
|
|
ILAYTP=IPOS
|
||
|
|
! call getint(nlay)
|
||
|
|
! READ(*,*) NLAY
|
||
|
|
!
|
||
|
|
! Write out current layers
|
||
|
|
!
|
||
|
|
7 CONTINUE
|
||
|
|
NHTP=0
|
||
|
|
NMESS=0
|
||
|
|
NBRR=4
|
||
|
|
CALL HEDR
|
||
|
|
CALL RCYAN
|
||
|
|
DO 10 K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .GT. 5) THEN
|
||
|
|
DO 9 N=1,NCORN(K),2
|
||
|
|
J=NOP(K,N)
|
||
|
|
FPN = LAY(J)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) - .11
|
||
|
|
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||
|
|
& Y .GT. 0. .AND. Y .LT. 7.0) THEN
|
||
|
|
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||
|
|
ENDIF
|
||
|
|
9 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
10 END DO
|
||
|
|
CALL RBLUE
|
||
|
|
!
|
||
|
|
! Input new layers
|
||
|
|
!
|
||
|
|
5 IBOX=1
|
||
|
|
CALL PROX(CORD(1,1),CORD(1,2),NP,XX,YY,INODE,IFLAG,INSKP,IBOX)
|
||
|
|
|
||
|
|
IF(IRMAIN .EQ. 1) THEN
|
||
|
|
REWIND 102
|
||
|
|
DO J=1,NP
|
||
|
|
IF(LAY(J) .GT. -9998) THEN
|
||
|
|
if(ILAYTP .eq. 1) then
|
||
|
|
write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
6000 format('LD2 ',2i8,9F8.2)
|
||
|
|
else
|
||
|
|
write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
6001 format('LD3 ',2i8,9F8.2)
|
||
|
|
endif
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
IF(IFLAG .EQ. 'c' .AND. IBOX .GT. 0) THEN
|
||
|
|
IFLAG=ANSW(IBOX)
|
||
|
|
ENDIF
|
||
|
|
IF(IFLAG .EQ. 'n') THEN
|
||
|
|
GO TO 4
|
||
|
|
ELSEIF(IFLAG .EQ. 'q') THEN
|
||
|
|
NLAYD=1
|
||
|
|
REWIND 102
|
||
|
|
DO J=1,NP
|
||
|
|
IF(LAY(J) .GT. -9998) THEN
|
||
|
|
if(ILAYTP .eq. 1) then
|
||
|
|
write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
else
|
||
|
|
write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
endif
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
RETURN
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
XPRT=XPRT+0.5
|
||
|
|
IF(XPRT .GT. HSIZE) XPRT=0.
|
||
|
|
FPN= INODE
|
||
|
|
CALL NUMBR(XPRT,7.20,0.2,FPN,0.0,-1)
|
||
|
|
IF (IFLAG .EQ. 'c') THEN
|
||
|
|
LAY(INODE) = NLAY
|
||
|
|
DO J=1,7
|
||
|
|
WTLAY(INODE,J)=RLAY(J)
|
||
|
|
ENDDO
|
||
|
|
FPN = NLAY
|
||
|
|
X = CORD(INODE,1)
|
||
|
|
Y = CORD(INODE,2) + .11
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
!
|
||
|
|
ELSEIF(IFLAG .EQ. 'a') THEN
|
||
|
|
DO 100 K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .GT. 5) THEN
|
||
|
|
DO 90 N=1,NCORN(K),2
|
||
|
|
J=NOP(K,N)
|
||
|
|
DO I=1,7
|
||
|
|
WTLAY(J,I)=RLAY(I)
|
||
|
|
ENDDO
|
||
|
|
LAY(J)=NLAY
|
||
|
|
FPN=NLAY
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) + .11
|
||
|
|
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||
|
|
& Y .GT. 0. .AND. Y .LT. 7.0) THEN
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
ENDIF
|
||
|
|
90 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
100 CONTINUE
|
||
|
|
NLAYD=1
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
ELSEIF(IFLAG .EQ. 'f') THEN
|
||
|
|
DO 120 K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
IF(NCORN(K) .GT. 5) THEN
|
||
|
|
DO 110 N=1,NCORN(K),2
|
||
|
|
J=NOP(K,N)
|
||
|
|
IF(LAY(J) .EQ. -9999.) THEN
|
||
|
|
LAY(J)=NLAY
|
||
|
|
DO I=1,7
|
||
|
|
WTLAY(J,I)=RLAY(I)
|
||
|
|
ENDDO
|
||
|
|
FPN=NLAY
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) + .11
|
||
|
|
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||
|
|
& Y .GT. 0. .AND. Y .LT. 7.0) THEN
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
110 CONTINUE
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
120 CONTINUE
|
||
|
|
NLAYD=1
|
||
|
|
CALL WRTOUT(0)
|
||
|
|
!
|
||
|
|
ELSE
|
||
|
|
!ipk jan98 WRITE(*,*) CHAR(7),CHAR(7)
|
||
|
|
ENDIF
|
||
|
|
!
|
||
|
|
GOTO 5
|
||
|
|
!
|
||
|
|
END
|
||
|
|
subroutine openlay
|
||
|
|
use winteracter
|
||
|
|
|
||
|
|
implicit none
|
||
|
|
|
||
|
|
include 'd.inc'
|
||
|
|
CHARACTER(LEN=255) :: FNAME
|
||
|
|
CHARACTER(LEN=3) :: SUB
|
||
|
|
LOGICAL :: OPENED
|
||
|
|
INTEGER :: IERR
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
INQUIRE(102, OPENED=OPENED)
|
||
|
|
if(.not. opened) then
|
||
|
|
CALL WSelectFile(ID_STRING9,SaveDialog+PromptOn,FNAME,'Save layer file')
|
||
|
|
|
||
|
|
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||
|
|
|
||
|
|
SUB='lay'
|
||
|
|
CALL ADDSUB(FNAME,SUB)
|
||
|
|
open(102,file=fname, form='formatted', status='unknown')
|
||
|
|
ENDIF
|
||
|
|
endif
|
||
|
|
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE RDLAYER
|
||
|
|
!
|
||
|
|
! Read nodal layer data
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*8 ID
|
||
|
|
CHARACTER*72 DLIN
|
||
|
|
DIMENSION WTTEMP(7)
|
||
|
|
|
||
|
|
!
|
||
|
|
100 CONTINUE
|
||
|
|
READ(103,7000,END=400) ID,DLIN
|
||
|
|
7000 FORMAT(A8,A72)
|
||
|
|
IF(ID(1:2) .EQ. 'LD') THEN
|
||
|
|
READ(DLIN,5000) NODNUM,NLAYD,(WTTEMP(I),I=1,7)
|
||
|
|
5000 FORMAT(2I8,7F8.0)
|
||
|
|
IF(NODNUM .EQ. 0) THEN
|
||
|
|
DO N=0,NP
|
||
|
|
LAY(N)=NLAYD
|
||
|
|
IF(NLAYD .GT. 0) THEN
|
||
|
|
DO I=0,NLAYD
|
||
|
|
WTLAY(N,I)=WTTEMP(I)
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ELSEIF(NODNUM .GT. 0) THEN
|
||
|
|
LAY(NODNUM)=NLAYD
|
||
|
|
IF(NLAYD .GT. 0) THEN
|
||
|
|
DO I=1,NLAYD
|
||
|
|
WTLAY(NODNUM,I)=WTTEMP(I)
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
|
||
|
|
ENDIF
|
||
|
|
ENDIF
|
||
|
|
IF(ID(3:3) .EQ. '2') THEN
|
||
|
|
ILAYTP=1
|
||
|
|
ELSE
|
||
|
|
ILAYTP=0
|
||
|
|
ENDIF
|
||
|
|
GO TO 100
|
||
|
|
400 CONTINUE
|
||
|
|
DO K=1,NE
|
||
|
|
IF(IMAT(K) .GT. 0) THEN
|
||
|
|
NCN=NCORN(K)
|
||
|
|
IF(NCN .EQ. 5) NCN=3
|
||
|
|
DO N=1,NCORN(K),2
|
||
|
|
J=NOP(K,N)
|
||
|
|
FPN=LAY(N)
|
||
|
|
X = CORD(J,1)
|
||
|
|
Y = CORD(J,2) + .11
|
||
|
|
IF(X .GT. 0. .AND. X .LT. HSIZE .AND. &
|
||
|
|
& Y .GT. 0. .AND. Y .LT. 7.0) THEN
|
||
|
|
CALL RRED
|
||
|
|
CALL NUMBR(X,Y,0.2,FPN,0.0,-1)
|
||
|
|
CALL RBLUE
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
ENDIF
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
END
|
||
|
|
|
||
|
|
SUBROUTINE WRTLAYER
|
||
|
|
use winteracter
|
||
|
|
|
||
|
|
!
|
||
|
|
! Read nodal layer data
|
||
|
|
!
|
||
|
|
USE BLK1MOD
|
||
|
|
! INCLUDE 'BLK1.COM'
|
||
|
|
CHARACTER*8 ID
|
||
|
|
CHARACTER*72 DLIN
|
||
|
|
DIMENSION WTTEMP(7)
|
||
|
|
LOGICAL :: OPENED
|
||
|
|
include 'd.inc'
|
||
|
|
CHARACTER(LEN=255) :: FNAME
|
||
|
|
CHARACTER(LEN=3) :: SUB
|
||
|
|
|
||
|
|
!
|
||
|
|
! Declare window-type and message variables
|
||
|
|
!
|
||
|
|
TYPE(WIN_STYLE) :: WINDOW
|
||
|
|
|
||
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
||
|
|
|
||
|
|
INQUIRE(102, OPENED=OPENED)
|
||
|
|
if(.not. opened) then
|
||
|
|
CALL WSelectFile(ID_STRING9,SaveDialog+PromptOn,FNAME,'Save layer file')
|
||
|
|
|
||
|
|
IF (WInfoDialog(ExitButtonCommon).EQ.CommonOpen) THEN
|
||
|
|
|
||
|
|
SUB='lay'
|
||
|
|
CALL ADDSUB(FNAME,SUB)
|
||
|
|
open(102,file=fname, form='formatted', status='unknown')
|
||
|
|
ENDIF
|
||
|
|
else
|
||
|
|
rewind 102
|
||
|
|
endif
|
||
|
|
|
||
|
|
DO J=0,NP
|
||
|
|
IF(LAY(J) .GT. -9998) THEN
|
||
|
|
if(j .gt. 0) then
|
||
|
|
if(lay(j) .ne. lay(0)) then
|
||
|
|
go to 300
|
||
|
|
else
|
||
|
|
do i=1,lay(j)
|
||
|
|
if(wtlay(j,i) .ne. wtlay(0,i)) then
|
||
|
|
go to 300
|
||
|
|
endif
|
||
|
|
enddo
|
||
|
|
endif
|
||
|
|
go to 500
|
||
|
|
300 continue
|
||
|
|
if(ILAYTP .eq. 1) then
|
||
|
|
write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
6000 format('LD2 ',2i8,9F8.2)
|
||
|
|
else
|
||
|
|
write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
6001 format('LD3 ',2i8,9F8.2)
|
||
|
|
endif
|
||
|
|
else
|
||
|
|
if(ILAYTP .eq. 1) then
|
||
|
|
write(102,6000) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
else
|
||
|
|
write(102,6001) J,LAY(J),(WTLAY(J,I),I=1,LAY(J))
|
||
|
|
endif
|
||
|
|
endif
|
||
|
|
ENDIF
|
||
|
|
500 CONTINUE
|
||
|
|
ENDDO
|
||
|
|
RETURN
|
||
|
|
END
|