! 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