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.
2742 lines
88 KiB
Fortran
2742 lines
88 KiB
Fortran
!IPK LAST UPDATE SEP 23 2015 ADD OPTION FOR SURFER FORMAT MAPS
|
|
!IPK LAST UPDATE FEB 11 2002 ADD LOCK AS VARIABLE AND READ NEW MAP FILE
|
|
!ipk jan99 fix restart file
|
|
!
|
|
!
|
|
!****************************************************************
|
|
!
|
|
SUBROUTINE WRTOUT(IFOM)
|
|
!ipk oct95 IFO replaced by IFOM because the value changes
|
|
!
|
|
! Write out updated data
|
|
!
|
|
! IFO = 0 write to backup
|
|
! IFO = 1 write to output in ASCII
|
|
!IPK MAR94 add a line
|
|
! IFO = -1 write to ASCII in emergency
|
|
! IFO = 2 write to output as binary
|
|
!
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
CHARACTER*55 FMTT
|
|
CHARACTER*39 FMTU
|
|
!IPK JUL98
|
|
CHARACTER*8 ID8
|
|
CHARACTER*60 LIND
|
|
CHARACTER*32 IJNK
|
|
!
|
|
DATA ISET /2/,ZERO/0.0/,VDXX/-1.E19/
|
|
!ipk oct95 copy IFO from IFOM
|
|
!ipk feb99 IOT=20
|
|
!ipk feb99 IOT1=22
|
|
if(ifom .eq. 3) then
|
|
write(iot,'(''MESH2D'')')
|
|
WRITE(IOT,'(''MESHNAME'')')
|
|
do n=1,ne
|
|
if(imat(n) .lt. 1) cycle
|
|
if(ncorn(n) .lt. 6) then
|
|
|
|
return
|
|
endif
|
|
if(ncorn(n) .eq. 8) then
|
|
if(nop(n,2) .eq. 0) then
|
|
write(iot,'(''E4Q'',6i10)') N,(NOP(N,K),K=1,7,2),IMAT(N)
|
|
else
|
|
write(iot,'(''E8Q'',10i10)') N,(NOP(N,K),K=1,8),IMAT(N)
|
|
endif
|
|
elseif(ncorn(n) .eq. 6) then
|
|
if(nop(n,2) .eq. 0) then
|
|
write(iot,'(''E3T'',5i10)') N,(NOP(N,K),K=1,5,2),IMAT(N)
|
|
else
|
|
write(iot,'(''E6T'',8i10)') N,(NOP(N,K),K=1,6),IMAT(N)
|
|
endif
|
|
elseif(ncorn(n) .eq. 3) then
|
|
if(nop(n,2) .eq. 0) then
|
|
write(iot,'(''E2L'',4i10)') N,(NOP(N,K),K=1,3,2),IMAT(N)
|
|
else
|
|
write(iot,'(''E3L'',5i10)') N,(NOP(N,K),K=1,3),IMAT(N)
|
|
endif
|
|
endif
|
|
enddo
|
|
DO N=1,NP
|
|
IF(XUSR(N) .LT. VDXX) CYCLE
|
|
WRITE(IOT,'(''ND'',I8,1P3E16.8)') N,XUSR(N),YUSR(N),WD(N)
|
|
ENDDO
|
|
IF(NCLM .EQ. 0) RETURN
|
|
DO K=1,NCLM
|
|
IF(ICCLN(K,1) .EQ. 0) CYCLE
|
|
DO J=1,LLIST(K)
|
|
ILIST(K,J)=ICCLN(K,J)
|
|
ENDDO
|
|
ILIST(K,LLIST(K))=-ILIST(K,LLIST(K))
|
|
ILIST(K,LLIST(K)+1)=K
|
|
DO JJ=1,LLIST(K)+1,10
|
|
IF(JJ+9 .GT. LLIST(K)+1) THEN
|
|
WRITE(IOT,'(''NS'',10I8)') (ILIST(K,J),J=JJ,LLIST(K)+1)
|
|
ELSE
|
|
WRITE(IOT,'(''NS'',10I8)') (ILIST(K,J),J=JJ,JJ+9)
|
|
ENDIF
|
|
ENDDO
|
|
ENDDO
|
|
return
|
|
endif
|
|
|
|
IF((IFOM .EQ. 2 .AND. IOT1 .EQ. 0) .OR. &
|
|
& (IFOM .EQ. 1 .AND. IOT .EQ. 0)) THEN
|
|
CALL CLRBOX
|
|
WRITE(LIND,*) 'You have attempted to save without opening save f&
|
|
&ile'
|
|
CALL SYMBL(0.2,7.80,0.20,LIND,0.0,60)
|
|
WRITE(LIND,*) 'Press return to continue'
|
|
CALL SYMBL(0.2,7.55,0.20,LIND,0.0,60)
|
|
CALL GTCHARX(IJNK,NDIG,5.0,7.6)
|
|
CALL CLRBOX
|
|
RETURN
|
|
ENDIF
|
|
IFO=IFOM
|
|
|
|
IF(IFO .GT. 0) THEN
|
|
!
|
|
! Check connectivity before saving
|
|
!
|
|
CALL CHKCON(IREP)
|
|
IF(IREP .EQ. 0) RETURN
|
|
ENDIF
|
|
!
|
|
! Setup 1-D
|
|
IOD=2
|
|
DO N=1,NE
|
|
IF(NCORN(N) .LT. 6) THEN
|
|
IF(NCORN(N) .EQ. 5) THEN
|
|
NCN=3
|
|
ELSE
|
|
NCN=NCORN(N)
|
|
ENDIF
|
|
DO K=1,NCN
|
|
INODE=NOP(N,K)
|
|
IF(INODE .GT. 0) IOD(INODE)=1
|
|
ENDDO
|
|
ELSE
|
|
DO K=1,8
|
|
INODE=NOP(N,K)
|
|
IF(INODE .GT. 0) then
|
|
IF(IOD(INODE) .EQ. 2) IOD(INODE)=0
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
ENDDO
|
|
DO J=1,NP
|
|
IF(IOD(J) .EQ. 0) THEN
|
|
WIDTH(J)=0.
|
|
SS1(J)=0.
|
|
SS2(J)=0.
|
|
WIDS(J)=0.
|
|
WIDBS(J)=0.
|
|
SSO(J)=0.
|
|
BS1(J)=0.
|
|
ENDIF
|
|
ENDDO
|
|
!IPK MAR94 add a line
|
|
IFO = ABS(IFO)
|
|
if((ifo .eq. 1 .and. igfgsw .eq. 0) .or. ifo .ne. 1) then
|
|
if(itrianout .eq. 0) CALL HEADIN(IFO,ISET)
|
|
endif
|
|
IF(IFO .EQ. 0 ) THEN
|
|
WRITE(IBAK) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE)
|
|
WRITE(IBAK) &
|
|
& (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), &
|
|
& WIDBS(J),SSO(J),BS1(J),J=1,NP)
|
|
!IPK MAR02 add BS1
|
|
!IPK JUL98 + (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J)
|
|
WRITE(IBAK) NLST
|
|
IF(NLST .GT. 0) THEN
|
|
WRITE(IBAK) (LLIST(J),J=1,NLST), &
|
|
& ((ILIST(J,I),I=1,LLIST(J)),J=1,NLST)
|
|
ENDIF
|
|
!IPK JAN01
|
|
WRITE(IBAK) NENTRY,NLAYD,NCLM
|
|
IF(NENTRY .GT. 0) THEN
|
|
WRITE(IBAK) ((NEF(I,J),J=1,3),I=1,NENTRY)
|
|
ENDIF
|
|
IF(NLAYD .GT. 0) THEN
|
|
WRITE(IBAK) (LAY(I),I=0,NP),((WTLAY(I,J),J=1,9),I=0,NP)
|
|
ENDIF
|
|
!IPK JAN01
|
|
IF(NCLM .GT. 0) THEN
|
|
WRITE(IBAK) ((ICCLN(I,J),J=1,350),I=1,NCLM)
|
|
ENDIF
|
|
IF(IBAK .EQ. 21) THEN
|
|
CLOSE (IBAK)
|
|
OPEN(IBAK,FILE='ELT.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost)
|
|
if(iost .gt. 0) then
|
|
OPEN(IBAK,FILE='ELT1.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost)
|
|
if(iost .gt. 0) then
|
|
OPEN(IBAK,FILE='ELT2.BAK',STATUS='UNKNOWN',FORM='UNFORMATTED',IOSTAT=iost)
|
|
if(iost .gt. 0) then
|
|
write(*,*) 'ERROR UNABLE TO OPEN ELT.BAK FILE'
|
|
write(*,*) 'PRESS RETURN TO END'
|
|
read(*,'(I5)') junk
|
|
STOP
|
|
endif
|
|
ENDIF
|
|
ENDIF
|
|
! OPEN(IBAK,FILE='ELT.BAK',STATUS='UNKNOWN',FORM='BINARY')
|
|
ENDIF
|
|
|
|
ELSEIF(IFO .EQ. 2) THEN
|
|
if(igfgswb .eq. 0) then
|
|
!ipk may02 REWIND IOT1
|
|
WRITE(IOT1) &
|
|
& NP,NE,(XUSR(J),YUSR(J),ZERO,WD(J),J=1,NP), &
|
|
& ((NOP(J,K),K=1,8),IMAT(J),THTA(J),IEM(J),J=1,NE), &
|
|
& (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,NP)
|
|
!IPK JUL98
|
|
ID8='part-2 '
|
|
WRITE(IOT1) ID8
|
|
WRITE(IOT1) (WIDBS(J),SSO(J),J=1,NP)
|
|
|
|
!IPK JAN01 Add part 3 write for continuity lines
|
|
IF(NCLM .GT. 0) THEN
|
|
ID8='part-3 '
|
|
WRITE(IOT1) ID8
|
|
WRITE(IOT1) NCLM,((ICCLN(I,J),J=1,350),I=1,NCLM)
|
|
ENDIF
|
|
!IPK JAN01 Add part 4 write for continuity lines
|
|
ID8='part-4 '
|
|
WRITE(IOT1) ID8
|
|
!ipk mar02 add BS1
|
|
write(iot1) (lock(j),bs1(j),j=1,np),&
|
|
nlst,((ilist(j,k),k=1,maeln),llist(j),j=1,maxln)
|
|
else
|
|
call wrtbin
|
|
endif
|
|
ELSE
|
|
if(igfgsw .eq. 0 .and. itrianout .eq. 0) then
|
|
IOF=IOT
|
|
|
|
JJ=0
|
|
DO 10 J=1,NE
|
|
IF (IMAT(J) .NE. 0) THEN
|
|
JJ=JJ+1
|
|
IF(IECHG .EQ. 0) IEM(JJ)=JJ
|
|
|
|
if(np .lt. 100000) then
|
|
WRITE(IOF,'(10I5,F10.3,I5)') &
|
|
& J, (NOP(J,K),K=1,8), IMAT(J),THTA(J),IEM(JJ)
|
|
else
|
|
WRITE(IOF,'(10I6,F10.3,I6)') &
|
|
& J, (NOP(J,K),K=1,8), IMAT(J),THTA(J),IEM(JJ)
|
|
endif
|
|
ENDIF
|
|
10 CONTINUE
|
|
!
|
|
!ipk jan98 restore 9999
|
|
if(np .lt. 100000) then
|
|
WRITE(IOF,'(I5)') 9999
|
|
else
|
|
WRITE(IOF,'(I6)') 9999
|
|
endif
|
|
!
|
|
! Write out nodal data
|
|
!
|
|
!ipk jun97 find max or min number in x or y
|
|
cminx=0.
|
|
cmaxx=0.
|
|
wdmin=1.e10
|
|
wdmax=-1.e10
|
|
do j=1,np
|
|
if(inew(j) .eq. 1) then
|
|
! write(90,*) j,xusr(j),yusr(j)
|
|
if(xusr(j) .gt. cmaxx) cmaxx=xusr(j)
|
|
if(yusr(j) .gt. cmaxx) cmaxx=yusr(j)
|
|
if(xusr(j) .lt. cminx) cminx=xusr(j)
|
|
if(yusr(j) .lt. cminx) cminx=yusr(j)
|
|
wdmin=min(wdmin,wd(j))
|
|
wdmax=max(wdmax,wd(j))
|
|
endif
|
|
enddo
|
|
if(abs(wdmin) .gt. abs(wdmax)) then
|
|
temp=log10(abs(wdmin))
|
|
elseif(wdmax .eq. 0.) then
|
|
temp=2.5
|
|
else
|
|
temp=log10(abs(wdmax))
|
|
endif
|
|
if(temp .gt. 2.) then
|
|
itp=3
|
|
elseif(temp .gt. 1.) then
|
|
itp=4
|
|
else
|
|
itp=5
|
|
endif
|
|
ndigp=1
|
|
if(cmaxx .gt. 1.) then
|
|
ndigp=int(log10(cmaxx))+1
|
|
endif
|
|
ndigm=2
|
|
if(abs(cminx) .gt. 1.) then
|
|
ndigm=int(log10(abs(cminx)))+2
|
|
endif
|
|
ndigo=max(ndigp,ndigm)
|
|
ndec=min(8-ndigo,4)
|
|
! write(90,*) 'ndigp',ndigp,ndigm,cmaxx,cminx,ndigo,ndec
|
|
if(ntempin .lt. 2) then
|
|
write(fmtt,6200) NDEC,NDEC,itp
|
|
!IPK JUL98 6200 format('(I10,F10.',i1,',F10.'I1,',F10.3,F10.1,2F10.3,F
|
|
!IPK FEB02 ALLOW FOR LOCK AND BS1
|
|
6200 format('(I10,F10.',i1,',F10.'I1,',F10.',I1,',F10.1,2F10.3,3F10.2,I10,F10.4)')
|
|
WRITE(FMTU,6201) NDEC,NDEC,ITP
|
|
!IPK FEB02 ALLOW FOR LOCK AND BS1
|
|
6201 format('(I10,F10.',i1,',F10.'I1,',F10.',I1,',60X,I10,F10.4)')
|
|
else
|
|
ndec=min(14-ndigo,4)
|
|
! write(fmtt,6202) NDEC+10,NDEC+10,ITP
|
|
write(fmtt,6202) NDEC+9,NDEC+9,ITP
|
|
6202 format('(I10,g20.',i2,',g20.'I2,',F10.',I1,',F10.1,2F10.3,3F10.2,I10,F10.4)')
|
|
! WRITE(FMTU,6203) NDEC+10,NDEC+10,ITP
|
|
WRITE(FMTU,6203) NDEC+9,NDEC+9,ITP
|
|
6203 format('(I10,g20.',i2,',g20.'I2,',F10.',I1,',60X,I10,F10.4)')
|
|
endif
|
|
DO 20 J=1,NP
|
|
IF (INEW(J) .EQ. 1) THEN
|
|
!ipk oct94 IF(WIDTH(J) .GT. 0.01) THEN
|
|
IF(WIDTH(J) .GT. 0.001 .or. bs1(j) .gt. 0.) THEN
|
|
!ipk feb97 WRITE(IOF, '(I10,2F10.3,F10.2,F10.1,2F10.3,F10.1
|
|
!IPK JUL97 WRITE(IOF, '(I10,3F10.3,F10.1,2F10.3,F10.1)')
|
|
!IPK FEB02 ADD LOCK AND BS1
|
|
|
|
WRITE(IOF, FMTT) &
|
|
& J,XUSR(J),YUSR(J),WD(J), &
|
|
& WIDTH(J),SS1(J),SS2(J),WIDS(J) &
|
|
& ,WIDBS(J),SSO(J),LOCK(J),BS1(J)
|
|
|
|
ELSE
|
|
! write(90,7777) fmtu,j,xusr(j),yusr(j),ndec,ndigo
|
|
7777 format(3x,a23,i5,2e15.6,2i8)
|
|
|
|
!ipk feb97 WRITE(IOF, '(I10,2F10.3,F10.2)')
|
|
!IPK JUL97 WRITE(IOF, '(I10,3F10.3)')
|
|
!ipk feb02 add lock AND BS1
|
|
WRITE(IOF, FMTU) &
|
|
& J,XUSR(J),YUSR(J),WD(J),lock(j),BS1(J)
|
|
ENDIF
|
|
ENDIF
|
|
20 CONTINUE
|
|
!ipk jan98 restore 9999
|
|
WRITE(IOF,'(I10)') 9999
|
|
IF(NLST .GT. 0) THEN
|
|
DO 30 J=1,NLST
|
|
IF(LLIST(J) .GT. 0) THEN
|
|
if(np .lt. 100000) then
|
|
WRITE(IOF,'(16I5)') (ILIST(J,I),I=1,LLIST(J))
|
|
else
|
|
WRITE(IOF,'(16I6)') (ILIST(J,I),I=1,LLIST(J))
|
|
endif
|
|
ENDIF
|
|
30 CONTINUE
|
|
ENDIF
|
|
!ipk jan98 restore 9999
|
|
WRITE(IOF,'(I5)') 9999
|
|
! IF(NLAYD .GT. 0) THEN
|
|
! WRITE(IOF,'(2I5)') (I,LAY(I),I=1,NP)
|
|
! ENDIF
|
|
WRITE(IOF,6000) NENTRY
|
|
6000 FORMAT(I5,20X,'NENTRY')
|
|
IF(NENTRY .GT. 0) THEN
|
|
WRITE(IOF,'(15I5)') (NEF(I,1),NEF(I,2),NEF(I,3),I=1,NENTRY)
|
|
ENDIF
|
|
WRITE(IOF,6001) NCLM
|
|
6001 FORMAT(I5,20X,'NCLM')
|
|
IF(NCLM .GT. 0) THEN
|
|
DO I=1,NCLM
|
|
DO J=1,350
|
|
IF(ICCLN(I,J) .EQ. 0) THEN
|
|
NTRAC=J-1
|
|
IF(NTRAC .GT. 0) THEN
|
|
WRITE(IOF,6002) I,(ICCLN(I,KK),KK=1,NTRAC)
|
|
6002 FORMAT('CC1',I5,9I8/('CC2',5X,9I8))
|
|
ELSE
|
|
WRITE(IOF,6002) I
|
|
ENDIF
|
|
GO TO 40
|
|
ENDIF
|
|
ENDDO
|
|
40 CONTINUE
|
|
ENDDO
|
|
ENDIF
|
|
WRITE(IOF,6003)
|
|
6003 FORMAT('ENDDATA')
|
|
elseif(itrianout .gt. 0) then
|
|
call wrtele(IOT,itrianout)
|
|
else
|
|
call wrtgfg(IOT)
|
|
endif
|
|
ENDIF
|
|
RETURN
|
|
END
|
|
!****************************************************************
|
|
SUBROUTINE HEADIN(IUNIT,ISET)
|
|
!
|
|
! Read and write header data
|
|
!
|
|
!****************************************************************
|
|
!
|
|
USE BLK1MOD
|
|
INTEGER*2 I32
|
|
CHARACTER*80 ALINE
|
|
!ipk dec97
|
|
character*40 dlin
|
|
CHARACTER*32 IJNK
|
|
!IPK JUL98
|
|
!ipk may02
|
|
CHARACTER*8 ID8
|
|
CHARACTER*3 ID
|
|
CHARACTER*1000 HEADER
|
|
|
|
COMMON /RECOD/ IRECD,TSPC
|
|
! INCLUDE 'BLK1.COM'
|
|
INCLUDE 'BFILES.I90'
|
|
INTEGER*2 NOP2(MAXE,8)
|
|
integer iunit,iset
|
|
DATA ISLP/0/,IPRT/1/,IPO/1/,IRO/1/,IRFN/0/,IGEN/0/,NXZL/0/,NITST/1/,ISCTXT/0/,IFILL/0/,IALTGM/1/
|
|
DATA HORIZ/10./,VERT/8./,XSALE/1./,YSALE/1./,XFACT/1./,YFACT/1./,AR/0./,ANG/0./
|
|
! ELSE
|
|
!ISLP=0
|
|
!IPRT=1
|
|
!IPO=1
|
|
!IRO=1
|
|
!IRFN=0
|
|
!IGEN=0
|
|
!NXZL=0
|
|
!NITST=1
|
|
!ISCTXT=0
|
|
!IFILL=0
|
|
!IALTGM=1
|
|
|
|
|
|
|
|
! IF ISET = 1 read file
|
|
! IUNIT = 0 get a title
|
|
! IUNIT ne 0 and IIN = 11 read RST header
|
|
! IUNIT ne 0 and IIN = 12 read GEO data
|
|
! IUNIT ne 0 and IIN = 10 read RM1 header
|
|
! IUNIT ne 0 and IIN = 10 ITRIAN .NE. 0 read ELE header
|
|
! IF ISET = 2 write file
|
|
! IUNIT = 0 write a backup header
|
|
! IUNIT = 0 write RM1 header
|
|
|
|
!
|
|
IF(ISET .EQ. 1) THEN
|
|
IF(IUNIT .EQ. 0) THEN
|
|
!
|
|
! Generate values
|
|
!
|
|
CALL SETD(23)
|
|
!ipk oct96 WRITE(*,*) 'Enter a title for output file'
|
|
WRITE(DLIN,'(a29)') 'Enter a title for output file'
|
|
!ipk oct96 change to dlin
|
|
! call symbl(0.5,5.0,0.25,dlin,0.0,29)
|
|
! ndig=29
|
|
! call gtcharx(title,ndig,0.,4.5)
|
|
|
|
IF(IRECD .NE. 2) call get_label(dlin,title)
|
|
|
|
!
|
|
|
|
!ipk oct96 end changes
|
|
!ipk oct96 READ(*,5000) TITLE
|
|
CALL SETD(2)
|
|
! ISPL=0
|
|
IPRT=1
|
|
IPNN=1
|
|
IPEN=1
|
|
IPO=1
|
|
IRO=1
|
|
IPP=0
|
|
IRFN=0
|
|
IGEN=0
|
|
NXZL=0
|
|
NITST=1
|
|
ISCTXT=0
|
|
IFILL=0
|
|
IALTGM=1
|
|
NLAYD=0
|
|
HORIZ=10.
|
|
VERT=8.
|
|
XSALE=0.
|
|
YSALE=0.
|
|
XFACT=0.
|
|
YFACT=0.
|
|
AR=0.
|
|
ANG=0.
|
|
xadded=0.
|
|
yadded=0.
|
|
ntempin=0.
|
|
ELSE
|
|
IF(IIN .EQ. 11) THEN
|
|
!IPK FEB03 READ(IIN) TITLE,NP,NE
|
|
!IPK FEB03 READ(IIN) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
|
!IPK FEB03 & ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
|
!IPK FEB03 READ(IIN) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG
|
|
!IPK FEB03 IF(IPP .GT. 0) READ(IIN) ALINE
|
|
CALL RDRST(1,IIN)
|
|
|
|
ELSEIF(IIN .EQ. 12) THEN
|
|
CALL SETD(23)
|
|
IPRT=1
|
|
IPNN=1
|
|
IPEN=1
|
|
IPO=1
|
|
IRO=1
|
|
IPP=0
|
|
IRFN=0
|
|
IGEN=0
|
|
NXZL=0
|
|
NITST=1
|
|
ISCTXT=0
|
|
IFILL=0
|
|
IALTGM=1
|
|
NLAYD=0
|
|
HORIZ=10.
|
|
VERT=8.
|
|
XSALE=0.
|
|
YSALE=0.
|
|
XFACT=0.
|
|
YFACT=0.
|
|
AR=0.
|
|
ANG=0.
|
|
xadded=0.
|
|
yadded=0.
|
|
ntempin=0.
|
|
!ipk oct96 WRITE(*,*) 'Enter a title for output file'
|
|
WRITE(dLIN,'(a29)') 'Enter a title for output file'
|
|
|
|
call get_label(dlin,title)
|
|
|
|
! call symbl(0.5,5.0,0.25,dlin,0.0,29)
|
|
! ndig=29
|
|
! call gtcharx(title,ndig,0.,4.5)
|
|
|
|
!ipk oct96 end changes
|
|
!ipk oct96 READ(*,5000) TITLE
|
|
CALL SETD(2)
|
|
IF(IGFG .EQ. 2) THEN
|
|
CALL RDBIN(IIN)
|
|
RETURN
|
|
ENDIF
|
|
!ipk dec97
|
|
read(iin,err=100) header
|
|
if(header(1:6) .eq. 'RMAGEN' .or. header(1:6) .eq. 'RMASIM') then
|
|
inopt=2
|
|
else
|
|
inopt=1
|
|
rewind iin
|
|
endif
|
|
read(iin) n1,m1
|
|
rewind iin
|
|
write(90,*) 'Apparent nodes and elements from file are'
|
|
write(90,'(i15,i10)') n1,m1
|
|
if(n1 .gt. maxp .or. m1 .gt. maxe) then
|
|
!
|
|
!...... Perhaps the file format is wrong, close and reopen
|
|
!
|
|
WRITE(DLIN,'(A32)') 'Parameter limits may be violated'
|
|
call symbl(0.5,4.5,0.20,dlin,0.0,32)
|
|
WRITE(DLIN,'(A35)') 'Retrying with alternate file format'
|
|
call symbl(0.5,4.2,0.20,dlin,0.0,35)
|
|
close (iin)
|
|
open(iin ,file=fnamkep,status='old',form='unformatted')
|
|
read(iin) n1,m1
|
|
write(90,*) 'Revised nodes and elements from file are'
|
|
write(90,'(i15,i10)') n1,m1
|
|
if(n1 .gt. maxp .or. m1 .gt. maxe) then
|
|
WRITE(DLIN,'(A31)') 'Parameter limits still violated'
|
|
call symbl(0.5,3.9,0.20,dlin,0.0,31)
|
|
WRITE(DLIN,'(A27)') 'Apparent nodes and elts are'
|
|
call symbl(0.5,3.6,0.20,dlin,0.0,27)
|
|
WRITE(DLIN,'(2i10)') n1,m1
|
|
call symbl(0.5,3.3,0.20,dlin,0.0,20)
|
|
WRITE(DLIN,'(A24)') 'Press enter to terminate'
|
|
call symbl(0.5,4.5,0.20,dlin,0.0,24)
|
|
CALL GTCHARX(ijnk,ndig,5.0,4.0)
|
|
!cipk aug00 read(*,'(i1)') junk
|
|
call quit_pgm
|
|
endif
|
|
endif
|
|
rewind iin
|
|
!ipk dec97 end changes
|
|
!ipk may02
|
|
if(inopt .eq. 2) then
|
|
read(iin,err=100) header
|
|
READ(IIN,ERR=100) &
|
|
& N1,M1,((CORD(J,K),K=1,2),ALPHA,WD(J),J=1,N1), &
|
|
& ((NOP(J,K),K=1,8),IMAT(J),THTA(J),I3,J=1,M1) &
|
|
& , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1)
|
|
!IPK JUL98
|
|
else
|
|
READ(IIN,ERR=100) &
|
|
& N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), &
|
|
& ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1) &
|
|
& , (WIDTH(J),SS1(J),SS2(J),WIDS(J),J=1,N1)
|
|
DO J=1,N1
|
|
DO K=1,2
|
|
CORD(J,K)=CORDSN(J,K)
|
|
ENDDO
|
|
ENDDO
|
|
DO J=1,M1
|
|
DO K=1,8
|
|
NOP(J,K)=NOP2(J,K)
|
|
ENDDO
|
|
ENDDO
|
|
endif
|
|
read(IIN,err=120,end=120) id8
|
|
if(id8(1:6) .eq. 'part-2') then
|
|
read(IIN,err=104) (widbs(j),sso(j),j=1,n1)
|
|
read(IIN,err=120,end=120) id8
|
|
endif
|
|
|
|
!IPK JAN01 Add part 3 write for continuity lines
|
|
if(id8(1:6) .eq. 'part-3') then
|
|
|
|
!ipk aug02 IF(NCLM .GT. 0) THEN
|
|
READ(IIN,ERR=104) NCLM,((ICCLN(I,J),J=1,350),I=1,NCLM)
|
|
!ipk aug02 ENDIF
|
|
read(IIN,err=120,end=120) id8
|
|
endif
|
|
!IPK DEB02 Add part 4 write for lock and BS1 lines and reordering
|
|
if(id8(1:6) .eq. 'part-4') then
|
|
read(iin,err=104,end=120) (lock(j),bs1(j),j=1,n1)
|
|
read(iin,err=104,end=90) &
|
|
nlst,((ilist(j,k),k=1,maeln),llist(j),j=1,maxln)
|
|
endif
|
|
GO TO 120
|
|
!IPK MAR04
|
|
90 NLST=0
|
|
DO J=1,MAXLN
|
|
LLIST(J)=0
|
|
DO K=1,MAELN
|
|
ILIST(J,K)=0
|
|
ENDDO
|
|
ENDDO
|
|
GO TO 120
|
|
|
|
100 READ(IIN,ERR=104) &
|
|
& N1,M1,((CORDSN(J,K),K=1,2),ALPHA,WD(J),J=1,N1), &
|
|
& ((NOP2(J,K),K=1,8),IMAT(J),THTA(J),I32,J=1,M1)
|
|
DO J=1,N1
|
|
DO K=1,2
|
|
CORD(J,K)=CORDSN(J,K)
|
|
ENDDO
|
|
ENDDO
|
|
DO J=1,M1
|
|
DO K=1,8
|
|
NOP(J,K)=NOP2(J,K)
|
|
ENDDO
|
|
ENDDO
|
|
GO TO 120
|
|
|
|
104 WRITE(90,*) 'Error reading binary geometry file'
|
|
!ipk jan98 CALL SETD(23)
|
|
call clscrn()
|
|
WRITE(aline,*) 'Error reading binary geometry file'
|
|
call symbl &
|
|
& (1.1,3.3,0.20,aline,0.0,80)
|
|
WRITE(aline,*) 'Press enter to exit'
|
|
call symbl &
|
|
& (1.1,3.0,0.20,aline,0.0,80)
|
|
ndig=1
|
|
CALL GTCHARX(IJNK,NDIG,5.0,7.6)
|
|
CALL Quit_Pgm
|
|
STOP
|
|
|
|
120 CONTINUE
|
|
NP=N1
|
|
NE=M1
|
|
ELSE
|
|
IF(IGFG .EQ. 0 .AND. ITRIAN .EQ. 0) THEN
|
|
READ(IIN,5000) TITLE
|
|
write(90,5000) title
|
|
5000 FORMAT( A80)
|
|
READ(IIN,5010) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
|
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
|
write(90,5010) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
|
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
|
5010 FORMAT( 15I5,2f10.1,i10)
|
|
READ(IIN,5011) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG
|
|
5011 FORMAT( 2F10.0,4F10.4,2F10.0 )
|
|
IF(IPP .GT. 0) READ(IIN,5012) ALINE
|
|
5012 FORMAT(A80)
|
|
ELSEIF(IGFG .GT. 0 .OR. ITRIAN .EQ. 1) THEN
|
|
write(90,*) 'reading gfg/TRIAN title'
|
|
IPRT=1
|
|
IPNN=1
|
|
IPEN=1
|
|
IPO=1
|
|
IRO=1
|
|
IPP=0
|
|
IRFN=0
|
|
IGEN=0
|
|
NXZL=0
|
|
NITST=1
|
|
ISCTXT=0
|
|
IFILL=0
|
|
IALTGM=1
|
|
NLAYD=0
|
|
HORIZ=10.
|
|
VERT=8.
|
|
XSALE=0.
|
|
YSALE=0.
|
|
XFACT=0.
|
|
YFACT=0.
|
|
AR=0.
|
|
ANG=0.
|
|
xadded=0.
|
|
yadded=0.
|
|
ntempin=0.
|
|
IF(IGFG .EQ. 1) THEN
|
|
DO I=1,10000
|
|
READ(IIN,'(A3,A77)') ID,DLIN
|
|
IF(ID .EQ. 'T1 ') THEN
|
|
TITLE(1:77)=DLIN
|
|
GO TO 140
|
|
ENDIF
|
|
ENDDO
|
|
ELSEIF(IGFG .EQ. 3) THEN
|
|
DO I=1,10000
|
|
READ(IIN,'(A8,A77)') ID8,DLIN
|
|
IF(ID8 .EQ. 'MESHNAME') THEN
|
|
TITLE(1:77)=DLIN
|
|
GO TO 140
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
140 CONTINUE
|
|
REWIND IIN
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
ELSE
|
|
IF(IUNIT .EQ. 0 ) THEN
|
|
IF(IPNN .NE. 1) THEN
|
|
ISLP=0
|
|
IPRT=1
|
|
IPNN=1
|
|
IPEN=1
|
|
IPO=1
|
|
IRO=1
|
|
IPP=0
|
|
IRFN=0
|
|
IGEN=0
|
|
NXZL=0
|
|
NITST=1
|
|
ISCTXT=0
|
|
IFILL=0
|
|
IALTGM=1
|
|
NLAYD=0
|
|
HORIZ=10.
|
|
VERT=8.
|
|
XSALE=0.
|
|
YSALE=0.
|
|
XFACT=0.
|
|
YFACT=0.
|
|
AR=0.
|
|
ANG=0.
|
|
xadded=0.
|
|
yadded=0.
|
|
ntempin=0
|
|
ENDIF
|
|
REWIND IBAK
|
|
WRITE(IBAK) TITLE,NP,NE
|
|
WRITE(IBAK) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
|
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
|
WRITE(IBAK) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG
|
|
IF(IPP .GT. 0) WRITE(IBAK) ALINE
|
|
ELSEIF(IUNIT .EQ. 1) THEN
|
|
IOF=IOT
|
|
REWIND IOF
|
|
!ipk nov02
|
|
!IPK MAR04
|
|
! if(ne .gt. 99999) then
|
|
if(np .gt. 99999) then
|
|
if(ntempin .eq. 0) then
|
|
ntempin=1
|
|
else
|
|
ntempin=3
|
|
endif
|
|
endif
|
|
ISLP=0
|
|
IPRT=1
|
|
IPO=1
|
|
IRO=1
|
|
IPP=0
|
|
IRFN=0
|
|
IGEN=0
|
|
NXZL=0
|
|
NITST=1
|
|
ISCTXT=0
|
|
IFILL=0
|
|
IALTGM=1
|
|
NLAYD=0
|
|
HORIZ=0
|
|
VERT=0
|
|
XSALE=0
|
|
YSALE=0
|
|
XFACT=0
|
|
YFACT=0
|
|
AR=0
|
|
ANG=0
|
|
WRITE(IOF,5000) TITLE
|
|
WRITE(IOF,5010) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
|
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
|
WRITE(IOF,5011) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG
|
|
IF(IPP .GT. 0) WRITE(IOF,5012) ALINE
|
|
ENDIF
|
|
ENDIF
|
|
RETURN
|
|
END
|
|
!
|
|
SUBROUTINE RDCORD(IUNIT)
|
|
!
|
|
! Read in coordinates
|
|
!
|
|
!IPK MAY02
|
|
USE WINTERACTER
|
|
USE BLK1MOD
|
|
|
|
include 'd.inc'
|
|
|
|
REAL*8 CX,CY,VALS(7)
|
|
|
|
|
|
DIMENSION IRLINE(16)
|
|
CHARACTER*1 IJNK,ans
|
|
character*30 blank
|
|
CHARACTER*32 ANS32
|
|
CHARACTER*77 DLIN2
|
|
CHARACTER*28 MESG
|
|
CHARACTER*3 ID
|
|
character*80 dlin
|
|
!ipk feb02 expand to 110
|
|
character*150 dlin1,DLIN1OUT
|
|
! INCLUDE 'BLK1.COM'
|
|
DATA IFIRST / 0 /
|
|
data blank/' '/
|
|
!
|
|
IF (IFIRST .EQ. 0) THEN
|
|
IF(IIN .EQ. 10) THEN
|
|
NP = 0
|
|
ENDIF
|
|
VOID = - 1.0E+10
|
|
VDX = -1.E+9
|
|
IFIRST = 1
|
|
ENDIF
|
|
ISTART=0
|
|
JZ=0
|
|
!
|
|
!
|
|
IF(IUNIT .EQ. 0) RETURN
|
|
IF(IUNIT .EQ. 10) THEN
|
|
IF(IGFG .gt. 0) REWIND IUNIT
|
|
!ipk oct96 upgrade to model limits
|
|
20 continue
|
|
IF(IGFG .EQ. 0 .AND. ITRIAN .EQ. 0) THEN
|
|
!IPK JUL98 read(iunit,'(a80)',end=98) dlin
|
|
!ipk feb02 expand to 110
|
|
!ipk may02 expand to 150
|
|
read(iunit,'(a150)',end=98) dlin1
|
|
if(dlin1(11:30) .eq. blank) go to 98
|
|
!IPK JUL98 READ(dlin,'(I10,7F10.0)') J, CX, CY, BELEV,
|
|
!ipk feb02 add lock and BS1
|
|
if(ntempin .lt. 2) then
|
|
READ(dlin1,'(I10,9F10.0,I10,F10.0)') J, CX, CY, BELEV, &
|
|
& WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11
|
|
else
|
|
READ(dlin1,'(I10,2f20.0,7F10.0,I10,F10.0)',err=8888) J, CX, CY, BELEV, &
|
|
& WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11
|
|
go to 8889
|
|
8888 do kcl=61,140
|
|
dlin1(kcl:kcl)=' '
|
|
enddo
|
|
READ(DLIN1,'(I10,2F20.0,7F10.0,I10,F10.0)') J, CX, CY, BELEV,&
|
|
WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11
|
|
8889 continue
|
|
|
|
|
|
endif
|
|
ELSEIF(ITRIAN .EQ. 1) THEN
|
|
IF(ISTART .EQ. 0) THEN
|
|
READ(IUNIT,*) NPPP,NDUM,NATTR
|
|
ISTART=1
|
|
ENDIF
|
|
READ(IUNIT,*) J,CX,CY,(VALS(K),K=1,NATTR)
|
|
IF(J .EQ. 0) THEN
|
|
J=NPPP
|
|
JZ=1
|
|
ENDIF
|
|
BELEV=-9999.
|
|
WDTHX=0.
|
|
SS1X=0.
|
|
SS2X=0.
|
|
WDSX=0.
|
|
WEL=0.
|
|
SSSO=0.
|
|
LOCK1=0
|
|
BS11=0.
|
|
IF(NATTR .GT. 0) BELEV=VALS(1)
|
|
IF(NATTR .GT. 1) WDTHX=VALS(2)
|
|
IF(NATTR .GT. 2) SS1X=VALS(3)
|
|
IF(NATTR .GT. 3) SS2X=VALS(4)
|
|
|
|
ELSE
|
|
|
|
!ipk jun02 Allow for GFGEN input
|
|
DO ICOUNTC=1,1000000
|
|
IF(ICOUNTC .EQ. 1) THEN
|
|
NLST=0
|
|
ILIST=0
|
|
KST=1
|
|
ENDIF
|
|
DO JJ=1,150
|
|
DLIN1(JJ:JJ)=' '
|
|
ENDDO
|
|
READ(IUNIT,'(A3,A150)', END=400) ID,DLIN1
|
|
IF(ID .EQ. 'GNN' .OR. ID .EQ. 'GWN') THEN
|
|
! Count the number of variables
|
|
I=0
|
|
ICOUNT=0
|
|
75 CONTINUE
|
|
IF(DLIN1(I+1:I+1) .NE. ' ') THEN
|
|
GO TO 80
|
|
ELSE
|
|
I=I+1
|
|
GO TO 75
|
|
ENDIF
|
|
80 I=I+1
|
|
IF(I .EQ. 151) THEN
|
|
ICOUNT =ICOUNT+1
|
|
GO TO 90
|
|
ENDIF
|
|
IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN
|
|
ICOUNT=ICOUNT+1
|
|
85 CONTINUE
|
|
IF(I+1 .EQ. 151) GO TO 90
|
|
IF(DLIN1(I+1:I+1) .EQ. ' ') THEN
|
|
I=I+1
|
|
GO TO 85
|
|
ELSE
|
|
GO TO 80
|
|
ENDIF
|
|
ELSE
|
|
GO TO 80
|
|
ENDIF
|
|
ELSEIF(ID(1:2) .EQ. 'ND') THEN
|
|
ICOUNT=4
|
|
go to 90
|
|
ELSEIF(ID(1:2) .EQ. 'NS') THEN
|
|
CALL PARSELIN(DLIN1,DLIN1OUT,ICLON,NCHARBL)
|
|
READ(DLIN1OUT,*) (ILIST(NLST+1,KK),KK=KST,KST+NCHARBL-1)
|
|
IF(ILIST(NLST+1,KST+NCHARBL-1) .LT. 0) THEN
|
|
NLST=NLST+1
|
|
LLIST(NLST)=NST+NCHARBL-1
|
|
DO K=1,LLIST(NLST)
|
|
ICCLN(NLST,K)=ABS(ILIST(NLST,K))
|
|
ENDDO
|
|
NCLM=MAX(NLST,NCLM)
|
|
KST=1
|
|
ELSEIF(ILIST(NLST+1,KST+NCHARBL-2) .LT. 0) THEN
|
|
LTD=ILIST(NLST+1,KST+NCHARBL-1)
|
|
NLST=NLST+1
|
|
LLIST(NLST)=KST+NCHARBL-2
|
|
DO K=1,KST+NCHARBL-2
|
|
ICCLN(LTD,K)=ABS(ILIST(NLST,K))
|
|
ENDDO
|
|
NCLM=MAX(LTD,NCLM)
|
|
KST=1
|
|
ELSE
|
|
KST=KST+NCHARBL
|
|
ENDIF
|
|
|
|
ENDIF
|
|
ENDDO
|
|
90 CONTINUE
|
|
DO K=1,7
|
|
VALS(K)=0.
|
|
ENDDO
|
|
READ(DLIN1,*) J,(VALS(K),K=1,ICOUNT-1)
|
|
! WRITE(109,'(A8,I8,10F15.6)') ID,J,(VALS(K),K=1,ICOUNT-1)
|
|
IF(ID .EQ. 'GNN' .OR. ID .EQ. 'ND ') THEN
|
|
CX=VALS(1)
|
|
CY=VALS(2)
|
|
BELEV=VALS(3)
|
|
NP = MAX(NP,J)
|
|
CORD(J,1) = CX
|
|
CORD(J,2) = CY
|
|
XUSR(J) = CX
|
|
YUSR(J) = CY
|
|
WD(J) = BELEV
|
|
INSKP(J)=0
|
|
INEW(J) = 1
|
|
GO TO 20
|
|
ELSE
|
|
WDTHX=VALS(1)
|
|
SS1X=VALS(2)
|
|
SS2X=VALS(3)
|
|
WDSX=VALS(4)
|
|
WIDTH(J)=WDTHX
|
|
SS1(J)=SS1X
|
|
SS2(J)=SS2X
|
|
WIDS(J)=WDSX
|
|
GO TO 20
|
|
ENDIF
|
|
ENDIF
|
|
!c IF (J .GT. 9000) GOTO 98
|
|
IF (J .GE. MAXP) THEN
|
|
!ipk jan98 CALL SETD(23)
|
|
call clscrn()
|
|
WRITE(dlin,*) ' Node number exceeds MAXP in RDCORD',j
|
|
call symbl &
|
|
& (1.1,3.3,0.20,dlin,0.0,80)
|
|
WRITE(90,*) ' Node number exceeds MAXP in RDCORD'
|
|
WRITE(DLIN,*) ' Press enter to exit'
|
|
call symbl &
|
|
& (1.1,3.0,0.20,dlin,0.0,80)
|
|
ndig=1
|
|
CALL GTCHARX(ANS32,ndig,5.0,4.0)
|
|
!ipk jan98 READ(*,'(A)') IJNK
|
|
CALL Quit_Pgm
|
|
STOP
|
|
ENDIF
|
|
NP = MAX(NP,J)
|
|
CORD(J,1) = CX
|
|
CORD(J,2) = CY
|
|
XUSR(J) = CX
|
|
YUSR(J) = CY
|
|
WD(J) = BELEV
|
|
WIDTH(J)=WDTHX
|
|
SS1(J)=SS1X
|
|
SS2(J)=SS2X
|
|
WIDS(J)=WDSX
|
|
!IPK JUL98
|
|
WIDBS(J)=WEL
|
|
SSO(J)=SSSO
|
|
INSKP(J)=0
|
|
INEW(J) = 1
|
|
!IPK FEB02 ADD LOCK
|
|
LOCK(J)=LOCK1
|
|
BS1(J)=BS11
|
|
IF(ITRIAN .EQ. 1) THEN
|
|
IF((JZ .EQ. 0 .AND. J .EQ. NPPP) .OR. (JZ .EQ. 1 .AND. J .EQ. NPPP-1)) GO TO 400
|
|
ENDIF
|
|
!
|
|
GOTO 20
|
|
!
|
|
98 CONTINUE
|
|
NLST=0
|
|
KK=0
|
|
102 continue
|
|
if(np .gt. 99999) then
|
|
READ(IUNIT,'(16I6)') IRLINE
|
|
else
|
|
READ(IUNIT,'(16I5)') IRLINE
|
|
endif
|
|
IF(IRLINE(1) .EQ. 9999 .or. IRLINE(1) .EQ. 99999) GO TO 300
|
|
IF(KK .EQ. 0) NLST=NLST+1
|
|
104 DO 105 K=1,16
|
|
IF(IRLINE(K) .EQ. 0) GO TO 106
|
|
KK=KK+1
|
|
ILIST(NLST,KK)=IRLINE(K)
|
|
105 CONTINUE
|
|
GO TO 102
|
|
106 CONTINUE
|
|
LLIST(NLST)=KK
|
|
KK=0
|
|
GO TO 102
|
|
300 CONTINUE
|
|
! IF(NLAYD .GT. 0) THEN
|
|
! DO 320 L=1,NP
|
|
! READ(IUNIT,'(2I5)') I,LAY(I)
|
|
! IF(I .GT. 9000) GO TO 325
|
|
! 320 CONTINUE
|
|
! 325 CONTINUE
|
|
! ENDIF
|
|
!IPK JAN01
|
|
READ(IUNIT,'(I5)',end=375) NENTRY
|
|
IF(NENTRY .GT. 0) THEN
|
|
READ(IUNIT,'(15I5)') (NEF(I,1),NEF(I,2),NEF(I,3),I=1,NENTRY)
|
|
ENDIF
|
|
READ(IUNIT,'(I5)', end=375) NCLM
|
|
write(90,*) 'INOUT-695 NCLM',nclm
|
|
IF(NCLM .GT. 0) THEN
|
|
READ(IUNIT,'(A3,A77)') ID,DLIN2
|
|
WRITE(90,'(''INOUT-698'',A3,A77)'),ID,DLIN
|
|
IF(ID .EQ. 'CC1') THEN
|
|
330 READ(DLIN2,'(I5,9I8)') I,(ICCLN(I,J),J=1,9)
|
|
WRITE(90,'(I5,9I8)') I,(ICCLN(I,J),J=1,9)
|
|
NL=1
|
|
340 NL=NL+9
|
|
READ(IUNIT,'(A3,A77)',end=375) ID,DLIN2
|
|
WRITE(90,'(''INOUT-705'',A3,A77)'),ID,DLIN
|
|
IF(ID .EQ. 'CC2') THEN
|
|
READ(DLIN2,'(5X,9I8)') (ICCLN(I,J),J=NL,NL+8)
|
|
ELSEIF(ID .EQ. 'CC1') THEN
|
|
GO TO 330
|
|
ELSEIF(ID .EQ. 'END') THEN
|
|
GO TO 375
|
|
ENDIF
|
|
GO TO 340
|
|
ENDIF
|
|
ENDIF
|
|
|
|
375 CONTINUE
|
|
WRITE(90,*) 'INOUT-718 NCLM',NCLM
|
|
ELSE
|
|
IF(IUNIT .EQ. 11) THEN
|
|
!IPK FEB03 READ(IUNIT) &
|
|
!IPK FEB03 & (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), &
|
|
!IPK FEB03 & WIDBS(J),SSO(J),BS1(J),J=1,NP)
|
|
!IPK FEB03!ipk jan99 + (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J)
|
|
!IPK FEB03 DO 350 J=1,NP
|
|
!IPK FEB03 CORD(J,1) = XUSR(J)
|
|
!IPK FEB03 CORD(J,2) = YUSR(J)
|
|
!IPK FEB03 INSKP(J)=0
|
|
!IPK FEB03 IF (CORD(J,1) .GT. VDX) THEN
|
|
!IPK FEB03 INEW(J) = 1
|
|
!IPK FEB03 ENDIF
|
|
!IPK FEB03 350 CONTINUE
|
|
!IPK FEB03 READ(IUNIT) NLST
|
|
!IPK FEB03 IF(NLST .GT. 0) THEN
|
|
!IPK FEB03 READ(IUNIT) (LLIST(J),J=1,NLST), &
|
|
!IPK FEB03 ((ILIST(J,I),I=1,LLIST(J)),J=1,NLST)
|
|
!IPK FEB03 ENDIF
|
|
|
|
!IPK FEB03 READ(IUNIT) NENTRY,NLAYD,NCLM
|
|
!IPK FEB03 IF(NENTRY .GT. 0) THEN
|
|
!IPK FEB03 READ(IUNIT) ((NEF(I,J),J=1,3),I=1,NENTRY)
|
|
!IPK FEB03 ENDIF
|
|
!IPK FEB03 IF(NLAYD .GT. 0) THEN
|
|
!IPK FEB03 READ(IUNIT) (LAY(I),I=1,NP)
|
|
!IPK FEB03 ENDIF
|
|
!IPK FEB03 IF(NCLM .GT. 0) THEN
|
|
!IPK FEB03 READ(IUNIT) ((ICCLN(I,J),J=1,350),I=1,NCLM)
|
|
!IPK FEB03 ENDIF
|
|
|
|
CALL RDRST(3,IUNIT)
|
|
|
|
ELSE
|
|
DO 360 J=1,NP
|
|
XUSR(J) = CORD(J,1)
|
|
YUSR(J) = CORD(J,2)
|
|
!!apr99 INSKP(J)=0
|
|
IF (CORD(J,1) .GT. VDX) THEN
|
|
INSKP(J)=0
|
|
INEW(J) = 1
|
|
ENDIF
|
|
360 CONTINUE
|
|
ENDIF
|
|
ENDIF
|
|
400 CONTINUE
|
|
WRITE(90,*) 'INOUT-762 NCLM',NCLM
|
|
|
|
!
|
|
!ipk jun02 look for nodes that do not have coordinates but are defined in NOP
|
|
|
|
do n=1,ne
|
|
if(imat(n) .gt. 0) then
|
|
ncn=ncorn(n)
|
|
if(ncn .eq. 3) then
|
|
n1=nop(n,2)
|
|
if(n1 .ne. 0) then
|
|
if(inew(n1) .ne. 1) then
|
|
cord(n1,1)=(cord(nop(n,1),1)+cord(nop(n,3),1))/2.
|
|
cord(n1,2)=(cord(nop(n,1),2)+cord(nop(n,3),2))/2.
|
|
XUSR(n1) = CORD(n1,1)
|
|
YUSR(n1) = CORD(n1,2)
|
|
INSKP(n1)=0
|
|
INEW(n1) = 1
|
|
endif
|
|
endif
|
|
elseif(ncn .gt. 5) then
|
|
do k=2,ncn,2
|
|
n1=nop(n,k)
|
|
IF(N1 .NE. 0) THEN
|
|
if(inew(n1) .ne. 1) then
|
|
kk=mod(k+1,ncn)
|
|
cord(n1,1)=(cord(nop(n,k-1),1)+cord(nop(n,kk),1))/2.
|
|
cord(n1,2)=(cord(nop(n,k-1),2)+cord(nop(n,kk),2))/2.
|
|
XUSR(n1) = CORD(n1,1)
|
|
YUSR(n1) = CORD(n1,2)
|
|
INSKP(n1)=0
|
|
INEW(n1) = 1
|
|
NP = MAX(NP,n1)
|
|
endif
|
|
ENDIF
|
|
if(inew(nop(n,k-1)) .eq. 0) then
|
|
CALL EltERRDisp(n,ims)
|
|
if(ims .eq. 1) CALL DELTEL(n)
|
|
go to 120
|
|
endif
|
|
enddo
|
|
120 continue
|
|
endif
|
|
endif
|
|
enddo
|
|
WRITE(90,*) 'INOUT-797 NCLM',NCLM
|
|
|
|
WRITE(MESG,6010) NE
|
|
6010 FORMAT(I7,' Nodes read from file')
|
|
CALL SYMBL(1.1,3.3,0.25,mesg,0.0,28)
|
|
|
|
RETURN
|
|
!
|
|
END
|
|
!
|
|
!****************************************************************
|
|
!
|
|
SUBROUTINE RDMAP(IFIRST,IMPP,JSTT,KSTT)
|
|
!
|
|
! Read in coordinates of map lines
|
|
!
|
|
USE WINTERACTER
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
DIMENSION NTMP(9)
|
|
DIMENSION VALS(2000)
|
|
INTEGER*8 II
|
|
|
|
!
|
|
|
|
INCLUDE 'TXFRM.COM'
|
|
!IPK MAY02 COMMON /TXFRM/ XS, YS, TXSCAL
|
|
!
|
|
CHARACTER*80 ALIN,lind
|
|
!ipk jan98 CHARACTER*1 IJNK
|
|
CHARACTER*1 ans
|
|
CHARACTER*32 ANS32
|
|
CHARACTER*5 LAB1
|
|
CHARACTER*9 LAB2
|
|
CHARACTER*8 LAB3
|
|
CHARACTER*12 LAB4
|
|
CHARACTER*4 HEDR
|
|
!
|
|
5 continue
|
|
|
|
IGUNIT=0
|
|
ielvsw=0
|
|
! IF (IFIRST .EQ. 0) THEN
|
|
IF(IFIRST .EQ. 2) IMP=IMPP
|
|
VOID = - 1.0E+10
|
|
VDX = -1.0E+9
|
|
CXO=VDX
|
|
CYO=VDX
|
|
DO 10 J=JSTT+1,MAXPL
|
|
CMAP(J,1) = VOID
|
|
CMAP(J,2) = VOID
|
|
XMAP(J) = VOID
|
|
YMAP(J) = VOID
|
|
9 CONTINUE
|
|
10 CONTINUE
|
|
write(90,*) 'maxpl in rdmap - 1 ',maxpl
|
|
!ipk jan98
|
|
ylv=7.9
|
|
call clscrn
|
|
! ENDIF
|
|
!
|
|
!ipkfeb94 added logic
|
|
if(imp .eq. 9) then
|
|
!
|
|
I=0
|
|
J=0
|
|
K=1
|
|
20 READ(IMP,'(A80)') ALIN
|
|
if(alin(1:5) .eq. 'NCOLS') THEN
|
|
CALL RDESRI(alin,j,k)
|
|
GO TO 98
|
|
ENDIF
|
|
!ipk oct96 addition to identify first point
|
|
KFIRST=0
|
|
I=I+1
|
|
IF(MOD(I,25) .EQ. 0) REWIND 90
|
|
WRITE(90,'(2i5,A65)') I,K,ALIN
|
|
!ipk oct94 3 lines added
|
|
if(mod(i,2000) .eq. 0) then
|
|
!ipk jan98 write(*,*) i,' map lines now processed'
|
|
ylv=ylv-0.3
|
|
if(ylv .lt. 0.1) then
|
|
ylv=7.9
|
|
call clscrn
|
|
endif
|
|
write(lind,6010) i
|
|
call symbl &
|
|
& (1.1,ylv,0.20,LIND,0.0,80)
|
|
endif
|
|
DO KC=1,5
|
|
IF(ALIN(KC:KC) .EQ. 'E' .OR. ALIN(KC:KC) .EQ. 'e') THEN
|
|
GO TO 98
|
|
ENDIF
|
|
ENDDO
|
|
READ(ALIN,*) LINTYP(K),VALL
|
|
valkp=vall
|
|
IF(K .GT. MAXLIN) THEN
|
|
!ipk dec09 CALL SETD(23)
|
|
!ipk jan98
|
|
!ipk dec09 WRITE(lind,*) 'Too many map lines. increase maxlin in common'
|
|
!ipk dec09 ylv=ylv-0.6
|
|
!ipk dec09 if(ylv .lt. 0.1) then
|
|
!ipk dec09 ylv=7.9
|
|
!ipk dec09 call clscrn
|
|
!ipk dec09 endif
|
|
!ipk dec09 call symbl &
|
|
!ipk dec09 & (1.1,ylv,0.20,LIND,0.0,80)
|
|
!ipk dec09 WRITE(90,*) 'Too many map lines. increase maxlin in common'
|
|
!ipk jan98 WRITE(*,*) ' Press enter to exit'
|
|
!ipk jan98 READ(*,'(A)') IJNK
|
|
!ipk dec09 WRITE(LIND,*) ' Press enter to exit'
|
|
!ipk dec09 call symbl &
|
|
!ipk dec09 & (1.1,ylv-0.3,0.20,lind,0.0,80)
|
|
!ipk dec09 ndig=1
|
|
!ipk dec09 CALL GTCHARX(ANS,IJNK,5.0,4.0)
|
|
!ipk dec09 CALL Quit_Pgm
|
|
|
|
MAXPLL=MAXPL
|
|
call ADJUSTMAP(MAXPLL)
|
|
MAXPL=MAXPLL
|
|
deallocate (CMAP,XMAP,YMAP,VAL,imap,NCRS)
|
|
|
|
allocate (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL))
|
|
|
|
ALLOCATE (imap(maxpl),NCRS(MAXPL))
|
|
|
|
maxpts=maxpl
|
|
ifirst=0
|
|
rewind imp
|
|
go to 5
|
|
|
|
ENDIF
|
|
21 CONTINUE
|
|
READ(IMP,'(A80)') ALIN
|
|
|
|
!ipk sep05
|
|
|
|
do jjj=1,80
|
|
if(alin(jjj:jjj) .eq. char(9)) then
|
|
alin(jjj:jjj)=','
|
|
endif
|
|
enddo
|
|
|
|
I=I+1
|
|
IF(MOD(I,25) .EQ. 0) REWIND 90
|
|
WRITE(90,'(2i5,A65)') I,K,ALIN
|
|
!ipk oct94 3 lines added
|
|
if(mod(i,10000) .eq. 0) then
|
|
!ipk jan98 write(*,*) i,' map lines now processed'
|
|
ylv=ylv-0.3
|
|
if(ylv .lt. 0.1) then
|
|
ylv=7.9
|
|
call clscrn
|
|
endif
|
|
write(lind,6010) i
|
|
6010 format(i8,' map points processed')
|
|
call symbl &
|
|
& (1.1,ylv,0.20,LIND,0.0,80)
|
|
endif
|
|
DO KC=1,5
|
|
IF(ALIN(KC:KC) .EQ. 'E' .OR. ALIN(KC:KC) .EQ. 'e') THEN
|
|
GO TO 97
|
|
ENDIF
|
|
ENDDO
|
|
!ipk oct96 change to permit more line types
|
|
!ipk jan01 IF(LINTYP(K) .NE. 2 .and. valkp .lt. -9998.) THEN
|
|
!IPK APR03 IF(LINTYP(K) .NE. 2 .and. valkp .ne. 0.) THEN
|
|
!IPK APR03 READ(ALIN,*) CX, CY
|
|
!IPK APR03 vall=valkp
|
|
!IPK APR03 ELSE
|
|
!IPK APR03 READ(ALIN,*) CX, CY, VALL
|
|
!IPK APR03 ENDIF
|
|
IF(LINTYP(K) .EQ. 2) THEN
|
|
READ(ALIN,*) CX, CY, VALL
|
|
ELSEIF(VALKP .LT. 9999.) THEN
|
|
READ(ALIN,*) CX, CY
|
|
vall=valkp
|
|
ELSEIF(VALKP .EQ. 9999.) THEN
|
|
READ(ALIN,*) CX, CY, VALL
|
|
ENDIF
|
|
!ipk oct96 addition to prevent test on first point
|
|
if(kfirst .ne. 0) then
|
|
IF(CX .EQ. CXO .AND. CY .EQ. CYO) GO TO 21
|
|
else
|
|
kfirst=1
|
|
endif
|
|
IF(J .EQ. MAXPL) THEN
|
|
CALL SETD(23)
|
|
!ipk jan98 WRITE(*,*) 'Too many map points. increase maxpl in co
|
|
!ipk jan98 WRITE(90,*) 'Too many map points. increase maxpl in c
|
|
!ipk jan98 WRITE(*,*) ' Press enter to exit'
|
|
!ipk jan98 READ(*,'(A)') IJNK
|
|
!ipk jan98
|
|
!ipk dec09 WRITE(lind,6030) maxpl
|
|
!ipk dec09 6030 format ('Map point exceed',i10,' increase maxpl in common' )
|
|
!ipk dec09 ylv=ylv-0.6
|
|
!ipk dec09 if(ylv .lt. 0.1) then
|
|
!ipk dec09 ylv=7.9
|
|
!ipk dec09 call clscrn
|
|
!ipk dec09 endif
|
|
!ipk dec09 call symbl &
|
|
!ipk dec09 & (1.1,ylv,0.20,LIND,0.0,80)
|
|
!ipk dec09 WRITE(90,6030) maxpl
|
|
!ipk jan98 WRITE(*,*) ' Press enter to exit'
|
|
!ipk jan98 READ(*,'(A)') IJNK
|
|
!ipk dec09 WRITE(LIND,*) ' Press enter to exit'
|
|
!ipk dec09 call symbl &
|
|
!ipk dec09 & (1.1,ylv-0.3,0.20,lind,0.0,80)
|
|
!ipk dec09 ndig=1
|
|
!ipk dec09 CALL GTCHARX(ANS,IJNK,5.0,4.0)
|
|
!ipk dec09 CALL Quit_Pgm
|
|
|
|
call ADJUSTMAP(MAXPL)
|
|
deallocate (CMAP,XMAP,YMAP,VAL,imap,NCRS)
|
|
|
|
allocate (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL))
|
|
|
|
ALLOCATE (imap(maxpl),NCRS(MAXPL))
|
|
|
|
maxpts=maxpl
|
|
|
|
rewind imp
|
|
go to 5
|
|
|
|
|
|
|
|
|
|
ENDIF
|
|
J=J+1
|
|
CMAP(J,1) = CX
|
|
CMAP(J,2) = CY
|
|
XMAP(J) = CX
|
|
YMAP(J) = CY
|
|
VAL(J) = VALL
|
|
CXO=CX
|
|
CYO=CY
|
|
!
|
|
GOTO 21
|
|
!
|
|
97 CONTINUE
|
|
J=J+1
|
|
K=K+1
|
|
GO TO 20
|
|
98 CONTINUE
|
|
!ipk feb94
|
|
klint=k-1
|
|
jlint=j
|
|
!ipk feb94 end change
|
|
J=J+1
|
|
|
|
!IPK FEB03
|
|
|
|
MAXPTS=J-2
|
|
|
|
write(90,*) 'maxpts in rdmap - 2 ',maxpts,xmap(908)
|
|
|
|
!IPK FEB02 SCLAE NEW VALUES
|
|
|
|
IF(IFIRST .EQ. 2) THEN
|
|
IF(CMAP(MAXPTS,1) .GE. VDX) MAXPTS=MAXPTS+1
|
|
DO K=1,MAXPTS
|
|
IF (CMAP(K,1) .GT. VDX) THEN
|
|
CMAP(K,1) = (CMAP(K,1)+XS)/TXSCAL
|
|
CMAP(K,2) = (CMAP(K,2)+YS)/TXSCAL
|
|
ENDIF
|
|
END DO
|
|
ENDIF
|
|
write(90,*) 'maxpts',maxpts
|
|
CLOSE(IMP)
|
|
! do k=1,maxpts
|
|
! write(90,*) cmap(k,1),cmap(k,2),xmap(k),ymap(k),val(k)
|
|
! enddo
|
|
RETURN
|
|
ELSEIF(IMP .EQ. 113) THEN
|
|
CALL READSHP
|
|
!
|
|
!
|
|
!ipkfeb94 logic to add binary read of map
|
|
!
|
|
elseif(imp .eq. 92 .OR. IMP .GT. 94) then
|
|
|
|
|
|
!ipk jan98 test for max lines
|
|
read(imp) klint,jlint
|
|
rewind imp
|
|
if(klint+KSTT .gt. maxlin .or. jlint +JSTT .gt. maxpl) then
|
|
call clscrn
|
|
write(lind,6310)
|
|
6310 format(' Compilation limits exceeded')
|
|
call symbl &
|
|
& (0.5,3.5,0.20,LIND,0.0,80)
|
|
write(lind,6311) maxpl,jlint
|
|
6311 FORMAT(' Maximum map points =',2i8,' points requested')
|
|
call symbl &
|
|
& (0.5,3.2,0.20,LIND,0.0,80)
|
|
write(lind,6312) maxlin,klint
|
|
6312 FORMAT( ' Maximum lines =',2i8,' lines requested')
|
|
call symbl &
|
|
& (0.5,2.9,0.20,LIND,0.0,80)
|
|
WRITE(LIND,*) ' Press enter to exit'
|
|
call symbl &
|
|
& (0.5,2.0,0.20,lind,0.0,80)
|
|
ndig=1
|
|
CALL GTCHARX(ANS32,IJNK,5.0,4.0)
|
|
CALL Quit_Pgm
|
|
STOP
|
|
endif
|
|
read(imp) klint,jlint,(xmap(j),ymap(j),val(j),j=JSTT+1,JSTT+jlint) &
|
|
& ,(lintyp(k),k=KSTT+1,KSTT+klint)
|
|
read(imp,end=200) nelts ,((nopel(j,k),k=1,3),j=1,nelts)
|
|
maxpts=jlint+JSTT
|
|
go to 220
|
|
200 continue
|
|
MAXPTS=JLINT+JSTT
|
|
nelts=0
|
|
220 continue
|
|
do j=JSTT+1,JSTT+jlint
|
|
cmap(j,1)=xmap(j)
|
|
cmap(j,2)=ymap(j)
|
|
enddo
|
|
JLINT=MAXPTS
|
|
KLINT=KSTT+klint
|
|
ELSEIF(IMP .EQ. 94) THEN
|
|
READ(IMP,'(A4)') HEDR
|
|
IF(HEDR .EQ. 'DSAA') THEN
|
|
READ(IMP,*) NCOLS1,NROWS1
|
|
maxpts=ncols1*nrows1
|
|
if(maxpts .gt. maxpl) then
|
|
maxpl=maxpts+1
|
|
deallocate (CMAP,XMAP,YMAP,VAL,imap,NCRS)
|
|
|
|
allocate (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL))
|
|
|
|
ALLOCATE (imap(maxpl),NCRS(MAXPL))
|
|
|
|
endif
|
|
READ(IMP,*) XXORG,XXTOP,YYORG,YYTOP
|
|
READ(IMP,*) DD1,DD2
|
|
DXINT=(XXTOP-XXORG)/(NCOLS1-1)
|
|
DYINT=(YYTOP-YYORG)/(NROWS1-1)
|
|
JJ=0
|
|
II=0
|
|
ANODAT=1.E36
|
|
READ(IMP,*) (VAL(I),I=1,MAXPTS)
|
|
DO J=NROWS1,1,-1
|
|
DO I=1,NCOLS1
|
|
II=II+1
|
|
IF(VAL(II) .GT. ANODAT) CYCLE
|
|
JJ=JJ+1
|
|
XMAP(JJ)=DXINT*(I-1)+XXORG
|
|
YMAP(JJ)=DYINT*(NROWS1+1-J)+YYORG
|
|
CMAP(JJ,1)=XMAP(JJ)
|
|
CMAP(JJ,2)=YMAP(JJ)
|
|
VAL(JJ)=VAL(II)
|
|
ENDDO
|
|
ENDDO
|
|
|
|
ELSE
|
|
REWIND IMP
|
|
READ(IMP,*) LAB1,NCOLS1
|
|
READ(IMP,*) LAB1,NROWS1
|
|
! INTV=1
|
|
! maxpts=ncols1*nrows1
|
|
! IF(MAXPTS .GT. 10000000) THEN
|
|
! CALL WMessageBox(OKOnly,ExclamationIcon,CommonOK,'Displayed Map Points reduced','EXCESSIVE MAP POINTS')
|
|
! INTVS=(MAXPTS/10000000)+1
|
|
! INTV=SQRT(FLOAT(INTVS))
|
|
! IF(INTV*INTV .LT. INTVS) THEN
|
|
! INTV=INTV+1
|
|
! ENDIF
|
|
! MAXPTS=MAXPTS/INTVS+INTVS
|
|
! ENDIF
|
|
! if(maxpts .gt. maxpl) then
|
|
! maxpl=maxpts+1
|
|
! deallocate (CMAP,XMAP,YMAP,VAL,imap,NCRS)
|
|
!
|
|
!allocate (CMAP(MAXPL,2),XMAP(MAXPL),YMAP(MAXPL),VAL(MAXPL))
|
|
!
|
|
!ALLOCATE (imap(maxpl),NCRS(MAXPL))
|
|
!
|
|
! endif
|
|
NSQ=MAX(NCOLS1,NROWS1)
|
|
IF(NSQ .GT. MAXLIN) THEN
|
|
MAXLIN=NSQ+10
|
|
DEALLOCATE (VALLIN,XCOL,YCOL)
|
|
ALLOCATE (VALLIN(MAXLIN),XCOL(MAXLIN),YCOL(MAXLIN))
|
|
ENDIF
|
|
READ(IMP,*) LAB2,XXORG
|
|
READ(IMP,*) LAB2,YYORG
|
|
READ(IMP,*) LAB3,CELLSIZX
|
|
READ(IMP,*) LAB3,CELLSIZY
|
|
IF(LAB3(1:6) .NE. 'NODATA') THEN
|
|
READ(IMP,*) LAB4,ANODAT
|
|
ELSE
|
|
ANODAT=CELLSIZY
|
|
CELLSIZY=CELLSIZX
|
|
ENDIF
|
|
II=0
|
|
jj=0
|
|
IGUNIT=203
|
|
XXORG=XXORG+CELLSIZX/2.
|
|
YYORG=YYORG+CELLSIZY/2.
|
|
DO J=1,NROWS1
|
|
YCOL(J)=CELLSIZY*(NROWS1+1-J)+YYORG
|
|
ENDDO
|
|
DO I=1,NCOLS1
|
|
XCOL(J)=CELLSIZX*(I-1)+XXORG
|
|
ENDDO
|
|
OPEN(IGUNIT,STATUS='UNKNOWN',FORM='BINARY',ACCESS='STREAM')
|
|
DO J=1,NROWS1
|
|
READ(IMP,*) (VALLIN(I),I=1,NCOLS1)
|
|
WRITE(203) (VALLIN(I),I=1,NCOLS1)
|
|
if(j .gt. 1) cycle
|
|
!jun06 IF(MOD(J,INTV) .NE. 0) CYCLE
|
|
DO I=1,NCOLS1
|
|
!jun06 DO I=1,NCOLS1,INTV
|
|
! II=II+1
|
|
! IF(VALLIN(I) .EQ. ANODAT) CYCLE
|
|
JJ=JJ+1
|
|
XMAP(JJ)=CELLSIZX*(I-1)+XXORG
|
|
YMAP(JJ)=CELLSIZY*(NROWS1+1-J)+YYORG
|
|
CMAP(JJ,1)=XMAP(JJ)
|
|
CMAP(JJ,2)=YMAP(JJ)
|
|
VAL(JJ)=VALLIN(I)
|
|
ENDDO
|
|
ENDDO
|
|
ENDIF
|
|
REWIND(IGUNIT)
|
|
MAXPTS=JJ
|
|
XMAP(MAXPTS+1)= VOID
|
|
|
|
KLINT=1
|
|
LINTYP(1)=2
|
|
else
|
|
|
|
! READ AN RM1 FILE AS A MAP FILE
|
|
|
|
! first headers
|
|
jlint=0
|
|
READ(IMP,'(a80)') alin
|
|
READ(IMP,5010) IPP,nnrl8
|
|
5010 FORMAT( 30x,i5,60x,i10)
|
|
READ(IMP,'(a80)') alin
|
|
IF(IPP .GT. 0) READ(IMP,'(a80)') ALIN
|
|
|
|
! next elements
|
|
|
|
230 CONTINUE
|
|
read(imp,'(a80)',end=300) ALIN
|
|
|
|
IF(ALIN(6:20) .EQ. ' ') GO TO 250
|
|
if(mod(nnrl8,2) .eq. 0) then
|
|
READ(ALIN,'(10I5)',END=250) J, (NTMP(K),K=1,9)
|
|
else
|
|
READ(ALIN,'(10I6)',END=250) J, (NTMP(K),K=1,9)
|
|
endif
|
|
NOPEL(J,1)=NTMP(1)
|
|
NOPEL(J,2)=NTMP(3)
|
|
NOPEL(J,3)=NTMP(5)
|
|
NELTS=MAX(J,NELTS)
|
|
GO TO 230
|
|
|
|
! finally nodes
|
|
250 CONTINUE
|
|
read(imp,'(a80)',end=300) ALIN
|
|
if(ALIN(11:30) .eq. ' ') go to 300
|
|
if(nnrl8 .lt. 2) then
|
|
READ(alin,'(I10,3F10.0)') J, CX, CY,BELEV
|
|
|
|
else
|
|
READ(alin,'(I10,2f20.0,F10.0)') J, CX, CY, BELEV
|
|
|
|
endif
|
|
xmap(j)=cx
|
|
CMAP(J,1)=CX
|
|
ymap(j)=cy
|
|
CMAP(J,2)=CY
|
|
val(j)=belev
|
|
jlint=max(j,jlint)
|
|
|
|
GO TO 250
|
|
|
|
300 maxpts=jlint
|
|
klint=1
|
|
lintyp(1)=2
|
|
ENDIF
|
|
|
|
!IPK FEB02 SCALE NEW VALUES
|
|
|
|
IF(IFIRST .EQ. 2) THEN
|
|
DO K=JSTT+1,MAXPTS
|
|
IF (CMAP(K,1) .GT. VDX) THEN
|
|
CMAP(K,1) = (CMAP(K,1)+XS)/TXSCAL
|
|
CMAP(K,2) = (CMAP(K,2)+YS)/TXSCAL
|
|
ENDIF
|
|
END DO
|
|
ENDIF
|
|
CLOSE(IMP)
|
|
return
|
|
END
|
|
!
|
|
!***********************************************************************
|
|
!
|
|
SUBROUTINE RDELEM(IUNIT)
|
|
!
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
INCLUDE 'BFILES.I90'
|
|
CHARACTER*1 AA,ANS
|
|
CHARACTER*32 ANS32
|
|
CHARACTER*81 DLIN
|
|
CHARACTER*150 DLIN1
|
|
CHARACTER*3 ID
|
|
!cipk aug00
|
|
CHARACTER*80 LIND
|
|
CHARACTER*25 BLANK
|
|
CHARACTER*31 MESG
|
|
DIMENSION NTMP(9),ATT(9)
|
|
!
|
|
DATA IFIRST / 0 /
|
|
DATA IERRL /0/
|
|
DATA BLANK /' '/
|
|
!ipk jul94 add a line
|
|
MEL=MAXE
|
|
!cipk aug00
|
|
ylv=7.5
|
|
!
|
|
! Read in existing elements
|
|
!
|
|
IF (IFIRST .EQ. 0) THEN
|
|
!
|
|
! Initialize arrays
|
|
!
|
|
VOID = - 1.0E+10
|
|
VDX = -1.E+9
|
|
IF(IIN .EQ. 10) NE = 0
|
|
IFIRST = 1
|
|
ENDIF
|
|
ISTART=0
|
|
NTMP=0
|
|
ATT=0.
|
|
!
|
|
IF(IUNIT .EQ. 0) RETURN
|
|
IF(IUNIT .EQ. 10) THEN
|
|
|
|
IF(IGFG .GT. 0) REWIND IUNIT
|
|
JZ=0
|
|
!ipk oct96 move around login to allow long length files
|
|
10 CONTINUE
|
|
IF(IGFG .EQ. 0 .AND. ITRIAN .EQ. 0) THEN
|
|
READ(IUNIT,'(A81)',END=98) DLIN
|
|
!ipk mar04 IF(DLIN(6:20) .EQ. BLANK .AND. IERRL .EQ. 0) THEN
|
|
IF(DLIN(7:20) .EQ. BLANK .AND. IERRL .EQ. 0) THEN
|
|
GO TO 175
|
|
!ipk dec97 generalize to allow multiple errors
|
|
!ipk dec97 ELSEIF(IERRL .EQ. 1) THEN
|
|
ELSEIF(IERRL .EQ. 1 .and. dlin(6:20) .eq. blank) THEN
|
|
CALL SETD(23)
|
|
!cipk aug00
|
|
WRITE(lind,6000)
|
|
6000 FORMAT(' Press enter to exit')
|
|
call symbl &
|
|
& (1.1,ylv-0.3,0.20,lind,0.0,80)
|
|
ndig=1
|
|
CALL GTCHARX(ANS32,IJNK,5.0,4.0)
|
|
CALL Quit_Pgm
|
|
STOP
|
|
|
|
ENDIF
|
|
ifree=1
|
|
do j=1,10
|
|
if(dlin(j:j) .eq. ',') then
|
|
ifree=0
|
|
endif
|
|
enddo
|
|
if(ifree .eq. 1) then
|
|
if(mod(ntempin,2) .eq. 0) then
|
|
READ(DLIN,'(10I5,F10.3,I5)',END=98) J, (NTMP(K),K=1,9),THT &
|
|
& ,NTEMP
|
|
else
|
|
READ(DLIN,'(10I6,F10.3,I6)',END=98) J, (NTMP(K),K=1,9),THT &
|
|
& ,NTEMP
|
|
endif
|
|
else
|
|
READ(DLIN,*,END=98) J, (NTMP(K),K=1,9),THT &
|
|
& ,NTEMP
|
|
endif
|
|
ELSEIF(ITRIAN .EQ. 1) THEN
|
|
IF(ISTART .EQ. 0) THEN
|
|
REWIND(IUNIT)
|
|
READ(IUNIT,*) NE,NCNTR,NATTR
|
|
ISTART=1
|
|
NMESS=2
|
|
INATTR=1
|
|
call GETINT(INATTR)
|
|
NMESS=0
|
|
ENDIF
|
|
READ(IUNIT,*) J,(NTMP(K),K=1,NCNTR),(ATT(K),K=1,NATTR)
|
|
IF(J .EQ. 0) THEN
|
|
JZ=1
|
|
J=NE
|
|
ENDIF
|
|
ELSE
|
|
!ipk jun02 Allow for GFGEN input
|
|
DO ICOUNTC=1,700000
|
|
DO JJ=1,150
|
|
DLIN1(JJ:JJ)=' '
|
|
ENDDO
|
|
READ(IUNIT,'(A3,A150)', END=175) ID,DLIN1
|
|
IF(ID .EQ. 'GE ') THEN
|
|
! Count the number of variables
|
|
I=0
|
|
ICOUNT=0
|
|
75 CONTINUE
|
|
IF(DLIN1(I+1:I+1) .NE. ' ') THEN
|
|
GO TO 80
|
|
ELSE
|
|
I=I+1
|
|
GO TO 75
|
|
ENDIF
|
|
80 I=I+1
|
|
IF(I .EQ. 151) THEN
|
|
ICOUNT =ICOUNT+1
|
|
GO TO 90
|
|
ENDIF
|
|
IF(DLIN1(I:I) .EQ. ' ' .OR. DLIN1(I:I) .EQ. ',') THEN
|
|
ICOUNT=ICOUNT+1
|
|
85 CONTINUE
|
|
IF(I+1 .EQ. 151) GO TO 90
|
|
IF(DLIN1(I+1:I+1) .EQ. ' ') THEN
|
|
I=I+1
|
|
GO TO 85
|
|
ELSE
|
|
GO TO 80
|
|
ENDIF
|
|
ELSE
|
|
GO TO 80
|
|
ENDIF
|
|
ELSEIF(ID .EQ. 'E3T') THEN
|
|
ICOUNT=4
|
|
GO TO 90
|
|
ELSEIF(ID .EQ. 'E4Q') THEN
|
|
ICOUNT=5
|
|
GO TO 90
|
|
ELSEIF(ID .EQ. 'E6T') THEN
|
|
ICOUNT=7
|
|
GO TO 90
|
|
ELSEIF(ID .EQ. 'E8Q') THEN
|
|
ICOUNT=9
|
|
GO TO 90
|
|
ENDIF
|
|
ENDDO
|
|
90 CONTINUE
|
|
IF(ICOUNT .GT. 10) THEN
|
|
READ(DLIN1,*) J, (NTMP(K),K=1,9),THT
|
|
ELSEIF(IGFG .EQ. 3) THEN
|
|
IF(ICOUNT .EQ. 4) THEN
|
|
READ(DLIN1,*) J, (NTMP(K),K=1,7,2)
|
|
IF(NTMP(7) .EQ. 0) then
|
|
NTMP(9)=1
|
|
else
|
|
ntmp(9)=ntmp(7)
|
|
endif
|
|
NTMP(2)=0
|
|
NTMP(4)=0
|
|
NTMP(6)=0
|
|
NTMP(7)=0
|
|
NTMP(8)=0
|
|
ELSEIF(ICOUNT .EQ. 5) THEN
|
|
READ(DLIN1,*) J, (NTMP(K),K=1,9,2)
|
|
IF(NTMP(9) .EQ. 0) NTMP(9)=1
|
|
NTMP(2)=0
|
|
NTMP(4)=0
|
|
NTMP(6)=0
|
|
NTMP(8)=0
|
|
ELSEIF(ICOUNT .EQ. 7) THEN
|
|
READ(DLIN1,*) J, (NTMP(K),K=1,6),NTMP(9)
|
|
IF(NTMP(9) .EQ. 0) NTMP(9)=1
|
|
NTMP(7)=0
|
|
NTMP(8)=0
|
|
ELSEIF(ICOUNT .EQ. 9) THEN
|
|
READ(DLIN1,*) J, (NTMP(K),K=1,9)
|
|
IF(NTMP(9) .EQ. 0) NTMP(9)=1
|
|
ENDIF
|
|
ELSE
|
|
READ(DLIN1,*) J, (NTMP(K),K=1,9)
|
|
ENDIF
|
|
ENDIF
|
|
|
|
!c IF (J .GT. 9000 .AND. IERRL .EQ. 0) THEN
|
|
!c GO TO 175
|
|
!IPK OCT96 END CHANGES
|
|
IF (J .GE. MEL) THEN
|
|
CALL SETD(23)
|
|
!cipk aug00
|
|
WRITE(lind,*) ' Element number exceeds MAXE in RDELEM'
|
|
call symbl &
|
|
& (1.1,ylv-0.3,0.20,lind,0.0,80)
|
|
ndig=1
|
|
WRITE(90,*) ' Element number exceeds MAXE in RDELEM'
|
|
WRITE(lind,6000)
|
|
CALL GTCHARX(ANS32,IJNK,5.0,4.0)
|
|
CALL Quit_Pgm
|
|
STOP
|
|
ENDIF
|
|
!
|
|
! Check to ensure there are no duplicate numbers in input stream
|
|
! of element connections
|
|
!
|
|
DO 12 K=1,7
|
|
IF(NTMP(K) .EQ. 0) GO TO 12
|
|
DO 11 L=K+1,8
|
|
IF(NTMP(K) .EQ. NTMP(L)) THEN
|
|
CALL SETD(23)
|
|
!cipk aug00
|
|
! WRITE(90,5000) J
|
|
! write(90,5001) (NTMP(MM),MM=1,8)
|
|
! WRITE(lind,5000) J
|
|
! call symbl &
|
|
! & (1.1,ylv-0.3,0.25,lind,0.0,80)
|
|
! ylv=ylv-0.3
|
|
! if(ylv .lt. 0.4) then
|
|
! call clscrn
|
|
! ylv=7.5
|
|
! endif
|
|
! write(lind,5001) (NTMP(MM),MM=1,8)
|
|
! call symbl &
|
|
! & (1.1,ylv-0.3,0.25,lind,0.0,80)
|
|
! ylv=ylv-0.3
|
|
! if(ylv .lt. 0.4) then
|
|
! call clscrn
|
|
! ylv=7.5
|
|
! endif
|
|
5000 FORMAT(' **ERROR** Nodes at element number',i5,' are duplicated')
|
|
5001 FORMAT(' node list as follows ',8i5)
|
|
! IERRL=1
|
|
DO KK=1,8
|
|
NOP(J,KK) = NTMP(KK)
|
|
ENDDO
|
|
IMAT(J)=NTMP(9)
|
|
call eltdisp(j)
|
|
DO KK=1,8
|
|
NTMP(KK) = NOP(J,KK)
|
|
ENDDO
|
|
NTMP(9)=IMAT(J)
|
|
GO TO 13
|
|
ENDIF
|
|
11 CONTINUE
|
|
12 CONTINUE
|
|
13 CONTINUE
|
|
IF(ITRIAN .EQ. 0) THEN
|
|
DO 15 K=1,8
|
|
NOP(J,K) = NTMP(K)
|
|
ND = NTMP(K)
|
|
IF (ND .GT. 0) THEN
|
|
INEW(ND) = 2
|
|
NP = MAX(NP,ND)
|
|
ENDIF
|
|
15 CONTINUE
|
|
IMAT(J) = NTMP(9)
|
|
THTA(J)=0
|
|
IEM(J) = j
|
|
ELSE
|
|
DO K=1,3
|
|
NOP(J,2*K-1)=NTMP(K)
|
|
IF(NCNTR .EQ. 3) THEN
|
|
NOP(J,2*K)=0
|
|
ELSEIF(NCNTR .EQ. 6) THEN
|
|
NOP(J,2*K)=NTMP(K+3)
|
|
ENDIF
|
|
ND = NTMP(K)
|
|
IF (ND .GT. 0) THEN
|
|
INEW(ND) = 2
|
|
NP = MAX(NP,ND)
|
|
ENDIF
|
|
ENDDO
|
|
NOP(J,7)=0
|
|
NOP(J,8)=0
|
|
IF(NATTR .GT. 0) THEN
|
|
IMAT(J)=ATT(1)+0.5
|
|
IF(NATTR .GT. 1) THEN
|
|
THTA(J)=ATT(2)
|
|
IF(NATTR .GT. 2) THEN
|
|
IEM(J)=ATT(3)
|
|
ELSE
|
|
IEM(J)=0
|
|
ENDIF
|
|
ELSE
|
|
THTA(J)=0.
|
|
IEM(J)=0
|
|
ENDIF
|
|
ELSE
|
|
IMAT(J)=INATTR
|
|
THTA(J)=0.
|
|
IEM(J)=0
|
|
ENDIF
|
|
ENDIF
|
|
NCN = 2
|
|
IF (NOP(J,3) .NE. 0) NCN = 3
|
|
IF (NOP(J,4) .NE. 0) NCN = 4
|
|
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5
|
|
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6
|
|
IF (NOP(J,6) .NE. 0) NCN = 6
|
|
IF (NOP(J,7) .NE. 0) NCN = 8
|
|
NCORN(J) = NCN
|
|
IESKP(J) = 0
|
|
DO 25 K=2,NCN,2
|
|
ND = NTMP(K)
|
|
IF (ND .GT. 0) THEN
|
|
IF(NCN .EQ. 5 .AND. K .EQ. 4) GO TO 25
|
|
WD(ND)=0.
|
|
ENDIF
|
|
25 CONTINUE
|
|
IF(ITRIAN .EQ. 1) THEN
|
|
IF((JZ .EQ. 0 .AND. J .EQ. NE) .OR. (JZ .EQ. 1 .AND. J .EQ. NE-1)) THEN
|
|
CLOSE(IUNIT)
|
|
DO L=255,1,-1
|
|
IF(FNAMKEP(L:L) .EQ. '.') THEN
|
|
FNAMKEP(L+1:L+1)='n'
|
|
FNAMKEP(L+2:L+2)='o'
|
|
FNAMKEP(L+3:L+3)='d'
|
|
FNAMKEP(L+4:L+4)='e'
|
|
OPEN(IUNIT,FILE=FNAMKEP,STATUS='OLD',ACTION='READ')
|
|
IF(JZ .EQ. 1) THEN
|
|
READ(IUNIT,*) NPPP,NDUM,NATTR
|
|
REWIND(IUNIT)
|
|
DO J=1,NE
|
|
DO K=1,5,2
|
|
IF(NOP(J,K) .EQ. 0) NOP(J,K)=NPPP
|
|
ENDDO
|
|
ENDDO
|
|
ENDIF
|
|
GO TO 175
|
|
ENDIF
|
|
ENDDO
|
|
ENDIF
|
|
ENDIF
|
|
NE = MAX(J,NE)
|
|
!
|
|
GOTO 10
|
|
!
|
|
98 CONTINUE
|
|
ELSE
|
|
IF(IUNIT .EQ. 11) THEN
|
|
!IPK FEB03 READ(IUNIT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE)
|
|
|
|
CALL RDRST(2,IUNIT)
|
|
ENDIF
|
|
DO 140 J=1,NE
|
|
IF(IMAT(J) .EQ. 0) GO TO 140
|
|
NCN = 2
|
|
IF (NOP(J,3) .NE. 0) NCN = 3
|
|
IF (NOP(J,4) .NE. 0) NCN = 4
|
|
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5
|
|
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6
|
|
IF (NOP(J,6) .NE. 0) NCN = 6
|
|
IF (NOP(J,7) .NE. 0) NCN = 8
|
|
NCORN(J) = NCN
|
|
IESKP(J) = 0
|
|
! DO 125 K=2,NCN,2
|
|
! ND = NOP(J,K)
|
|
! IF (ND .GT. 0) THEN
|
|
! IF(NCN .EQ. 5 .AND. K .EQ. 4) GO TO 125
|
|
! WD(ND)=0.
|
|
! ENDIF
|
|
! 125 CONTINUE
|
|
140 CONTINUE
|
|
ENDIF
|
|
!
|
|
! Set up junction counter array
|
|
!
|
|
175 CONTINUE
|
|
DO 180 N=1,NP
|
|
IJUN(N)=0
|
|
180 END DO
|
|
DO 200 N=1,NE
|
|
!ipkoct93 IF(IMAT(N) .GT. 900) THEN
|
|
IF(IMAT(N) .GT. 900 .AND. IMAT(N) .LT. 904) THEN
|
|
DO 190 K=1,NCORN(N)
|
|
IF(NOP(N,K) .GT. 0) THEN
|
|
IJUN(NOP(N,K))=K
|
|
ENDIF
|
|
190 CONTINUE
|
|
ENDIF
|
|
200 END DO
|
|
WRITE(MESG,6010) NE
|
|
6010 FORMAT(I7,' Elements read from file')
|
|
CALL SYMBL(1.1,4.3,0.25,mesg,0.0,31)
|
|
RETURN
|
|
END
|
|
SUBROUTINE CHKCON(IREP)
|
|
USE WINTERACTER
|
|
!
|
|
! Check connectivity of grid
|
|
!
|
|
!-
|
|
USE BLK1MOD
|
|
USE BLK2MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
! INCLUDE 'BLK2.COM'
|
|
CHARACTER*80 LIND
|
|
!
|
|
CHARACTER*1 ANS
|
|
! CHARACTER*60 STRELS
|
|
! DATA STRELS/' You have tried to save before executing "FILL"'/
|
|
!
|
|
! Test to make sure fill has been executed.
|
|
!
|
|
IF(IREP .EQ. 1) GO TO 100
|
|
ylv=7.5
|
|
IREP = 1
|
|
DO 70 N=1,NE
|
|
IF(IMAT(N) .GT. 0) THEN
|
|
DO 60 M=2,NCORN(N),2
|
|
IF(NOP(N,M) .EQ. 0 .AND. IMAT(N) .NE. 999) THEN
|
|
CALL GETSVPN(ANS)
|
|
IF(ANS .EQ. 'T' .OR. ANS .EQ. 't') THEN
|
|
IREP = 0
|
|
!ipk nov97 add 0
|
|
CALL PLOTOT(0)
|
|
CALL HEDR
|
|
RETURN
|
|
ELSEIF(ANS .EQ. 'S' .OR. ANS .EQ. 's') THEN
|
|
!ipk nov97 add (0)
|
|
CALL PLOTOT(0)
|
|
CALL HEDR
|
|
IREP = 1
|
|
return
|
|
! go to 100
|
|
!ipk jun04 RETURN
|
|
ELSEIF(ANS .EQ. 'F' .OR. ANS .EQ. 'f') THEN
|
|
!ipk aug02
|
|
CALL FILM(0)
|
|
IREP = 1
|
|
ELSE
|
|
IREP = 2
|
|
ENDIF
|
|
ENDIF
|
|
60 CONTINUE
|
|
ENDIF
|
|
70 END DO
|
|
100 CONTINUE
|
|
|
|
|
|
IDUP=0
|
|
call kcon(1)
|
|
do n=1,ne
|
|
if(imat(n) .lt. 900 .and. imat(n) .gt. 0) then
|
|
ndup=0
|
|
do j=2,ncorn(n),2
|
|
if(nop(n,j) .eq. 0) go to 120
|
|
if(ndelm(nop(n,j)) .gt. 2) then
|
|
ndup=ndup+1
|
|
endif
|
|
enddo
|
|
if(ndup .eq. ncorn(n)/2) then
|
|
IDUP=1
|
|
write(90,*) ' DUPLICATE ELEMENT',n
|
|
endif
|
|
endif
|
|
enddo
|
|
|
|
120 continue
|
|
|
|
IF(IDUP .EQ. 1) THEN
|
|
!cipk aug00
|
|
|
|
Call WMessageBox(1,3,0,'Duplicate elements have been found'//Char(13)//&
|
|
'See file MESSGEN.OUT for details'//'Press OK to continue save',&
|
|
'ERROR IN NETWORK!!')
|
|
IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then
|
|
CALL HEDR
|
|
CALL PLOTOT(0)
|
|
IREP = 1
|
|
ELSE
|
|
IREP = 0
|
|
CALL HEDR
|
|
!ipk nov97 add (0)
|
|
CALL PLOTOT(0)
|
|
RETURN
|
|
ENDIF
|
|
endif
|
|
|
|
!
|
|
! Test for areas of each element
|
|
!
|
|
INEG = 0
|
|
DO 250 N=1,NE
|
|
IF(IMAT(N) .GT. 0 .AND. NCORN(N) .GT. 5) THEN
|
|
J1=NOP(N,1)
|
|
J2=NOP(N,3)
|
|
J3=NOP(N,5)
|
|
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
|
|
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
|
|
IF(AREA .LT. 0.) THEN
|
|
! IF(INEG .EQ. 0) CALL CLSCRN
|
|
! CALL SETD(23)
|
|
!cipk aug00
|
|
! WRITE(lind,*) 'Negative area for element number',N
|
|
WRITE(90,*) ' NEGATIVE AREA FOR ELEMENT NUMBER',N
|
|
! if(ylv .lt. 0.4) then
|
|
! ylv=7.5
|
|
! call clscrn
|
|
! endif
|
|
! call symbl &
|
|
! & (1.1,ylv-0.3,0.20,lind,0.0,80)
|
|
! ylv=ylv-0.3
|
|
! ndig=1
|
|
INEG = 1
|
|
GO TO 250
|
|
ENDIF
|
|
IF(NCORN(N) .EQ. 8) THEN
|
|
J1=NOP(N,3)
|
|
J2=NOP(N,5)
|
|
J3=NOP(N,7)
|
|
AREA=(CORD(J2,1)-CORD(J1,1))*(CORD(J3,2)-CORD(J1,2))- &
|
|
& (CORD(J3,1)-CORD(J1,1))*(CORD(J2,2)-CORD(J1,2))
|
|
IF(AREA .LT. 0.) THEN
|
|
! IF(INEG .EQ. 0) CALL CLSCRN
|
|
! CALL SETD(23)
|
|
!cipk aug00
|
|
! WRITE(lind,*) 'Negative area for element number',N
|
|
WRITE(90,*) 'Negative area for element number',N
|
|
! if(ylv .lt. 0.4) then
|
|
! ylv=7.5
|
|
! call clscrn
|
|
! endif
|
|
! call symbl &
|
|
! & (1.1,ylv-0.3,0.20,lind,0.0,80)
|
|
! ylv=ylv-0.3
|
|
! ndig=1
|
|
INEG = 1
|
|
ENDIF
|
|
ENDIF
|
|
ENDIF
|
|
250 END DO
|
|
|
|
IF(INEG .EQ. 1) THEN
|
|
!cipk aug00
|
|
|
|
Call WMessageBox(1,3,0,'Negative Areas have been found'//Char(13)//&
|
|
'See file MESSGEN.OUT for details'//'Press OK to continue save',&
|
|
'ERROR IN NETWORK!!')
|
|
|
|
! WRITE(lind,*) 'If you wish to terminate save enter (t)'
|
|
! if(ylv .lt. 0.7) then
|
|
! ylv=7.5
|
|
! call clscrn
|
|
! endif
|
|
! call symbl &
|
|
! & (1.1,ylv-0.3,0.20,lind,0.0,80)
|
|
! ylv=ylv-0.3
|
|
! WRITE(lind,*) 'If you still wish to save enter (s)'
|
|
! call symbl &
|
|
! & (1.1,ylv-0.3,0.20,lind,0.0,80)
|
|
|
|
!ipk jun96 change * to (a)
|
|
|
|
!cipkaug00 READ(*,'(A)') ANS
|
|
! READ(*,*) ANS
|
|
! CALL GTCHARX(ANS,IJNK,5.0,4.0)
|
|
|
|
! CALL SETD(2)
|
|
! IF(ANS .EQ. 'T' .OR. ANS .EQ. 't') THEN
|
|
IF(WinfoDialog(ExitButtonCommon) .eq. CommonOK) then
|
|
CALL HEDR
|
|
CALL PLOTOT(0)
|
|
IREP = 1
|
|
RETURN
|
|
ELSE
|
|
IREP = 0
|
|
CALL HEDR
|
|
!ipk nov97 add (0)
|
|
CALL PLOTOT(0)
|
|
RETURN
|
|
ENDIF
|
|
! ELSEIF(ANS .EQ. 'S' .OR. ANS .EQ. 's') THEN
|
|
! CALL HEDR
|
|
!ipknov97 add (0)
|
|
! CALL PLOTOT(0)
|
|
! IREP = 1
|
|
! RETURN
|
|
! ENDIF
|
|
ENDIF
|
|
|
|
RETURN
|
|
END
|
|
!ipk oct98 update call
|
|
SUBROUTINE WRTMAP(isw)
|
|
!
|
|
! Write map file in binary format
|
|
!
|
|
USE BLKMAP
|
|
USE BLK1MOD
|
|
USE BLK2MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
! INCLUDE 'BLK2.COM'
|
|
character*3 ends
|
|
!
|
|
!
|
|
! Open binary map file
|
|
!
|
|
IF(ISW .GT. 90) THEN
|
|
IMPF=ISW
|
|
ELSE
|
|
impf=93
|
|
ENDIF
|
|
|
|
!ipk oct98
|
|
if(isw .eq. 0) then
|
|
OPEN(IMPF ,FILE=mpnam,STATUS='unknown',form='unformatted')
|
|
!IPK FRB03
|
|
else
|
|
rewind impf
|
|
endif
|
|
|
|
if(isw .eq. 2) then
|
|
impf=94
|
|
aninin=-9999.
|
|
zero=0.
|
|
ends='END'
|
|
if(lintyp(1) .eq. 0 .or. lintyp(1) .eq. 1) then
|
|
write(impf,*) lintyp(1),aninin
|
|
ifm=1
|
|
elseif(lintyp(1) .eq. 2) then
|
|
write(impf,*) lintyp(1),zero
|
|
ifm=2
|
|
else
|
|
write(impf,*) lintyp(1),val(1)
|
|
ifm=1
|
|
endif
|
|
ilin=1
|
|
do J=1,maxpts
|
|
if(xmap(J) .gt. vdx) then
|
|
if(ifm .eq. 1) then
|
|
write(impf,*) xmap(j),ymap(j)
|
|
else
|
|
write(impf,*) xmap(j),ymap(j),val(j)
|
|
endif
|
|
if(j .eq. maxpts) write(impf,'(a3)') ends
|
|
else
|
|
write(impf,'(a3)') ends
|
|
ilin=ilin+1
|
|
if(j .eq. maxpts) go to 200
|
|
if(lintyp(ilin) .eq. 0 .or. lintyp(ilin) .eq. 1) then
|
|
write(impf,*) lintyp(ilin),aninin
|
|
ifm=1
|
|
elseif(lintyp(ilin) .eq. 2) then
|
|
write(impf,*) lintyp(ilin),zero
|
|
ifm=2
|
|
else
|
|
write(impf,*) lintyp(ilin),val(j+1)
|
|
ifm=1
|
|
endif
|
|
endif
|
|
|
|
enddo
|
|
200 continue
|
|
write(impf,'(a3)') ends
|
|
return
|
|
endif
|
|
jlint=maxpts
|
|
write(impf) klint,jlint,(xmap(j),ymap(j),val(j),j=1,jlint) &
|
|
& ,(lintyp(k),k=1,klint)
|
|
|
|
if(nelts .gt. 0) then
|
|
write(impf) nelts,((nopel(j,k),k=1,3),j=1,nelts)
|
|
endif
|
|
return
|
|
END
|
|
|
|
SUBROUTINE GETSVPN(ANS)
|
|
|
|
use winteracter
|
|
|
|
implicit none
|
|
|
|
include 'D.inc'
|
|
|
|
!
|
|
! Declare window-type and message variables
|
|
!
|
|
TYPE(WIN_STYLE) :: WINDOW
|
|
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
|
INTEGER :: IPOS
|
|
INTEGER :: JNK,ierr
|
|
CHARACTER*1 :: ANS,CDAT(4)
|
|
DATA CDAT/'s','t','f','c'/
|
|
call wdialogload(IDD_DIALOG07)
|
|
ierr=infoerror(1)
|
|
|
|
|
|
call wdialogputRadioButton(idf_radio1)
|
|
|
|
|
|
CALL WDialogSelect(IDD_DIALOG07)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
|
ierr=infoerror(1)
|
|
|
|
|
|
do
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
|
|
|
call wdialoggetradiobutton(idf_radio1,ipos)
|
|
ans=cdat(ipos)
|
|
return
|
|
endif
|
|
!IPK SEP02
|
|
ans=cdat(1)
|
|
return
|
|
enddo
|
|
RETURN
|
|
END
|
|
|
|
!***************************************************************************************
|
|
|
|
subroutine wrtgfg(IOF)
|
|
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
IOF=IOT
|
|
WRITE(IOF,5000) TITLE
|
|
5000 format('T1'/'T2'/'T3 ',A80)
|
|
WRITE(IOF,5001)
|
|
5001 FORMAT('SI 1')
|
|
WRITE(IOF,5002)
|
|
5002 FORMAT('$L 3 0 6 0')
|
|
!
|
|
! CURRENTLY DISABLED
|
|
!
|
|
! IF(NLST .GT. 0) THEN
|
|
! DO J=1,NLST
|
|
! IF(LLIST(J) .GT. 0) THEN
|
|
! IF(J .EQ. 1) THEN
|
|
! ILIST(J,LLIST(J))=-ABS(ILIST(J,LLIST(J)))
|
|
! ENDIF
|
|
! WRITE(IOF,5003) (ILIST(J,I),I=1,LLIST(J))
|
|
! 5003 FORMAT('GO 2',11I6/('GO',12I6))
|
|
! ENDIF
|
|
! ENDDO
|
|
! ENDIF
|
|
DO J=1,NE
|
|
IF (IMAT(J) .NE. 0) THEN
|
|
IF(IECHG .EQ. 0) IEM(J)=J
|
|
WRITE(IOF,5004) &
|
|
& J, (NOP(J,K),K=1,8), IMAT(J),THTA(J)
|
|
5004 FORMAT('GE',10(1X,I6),F17.4)
|
|
ENDIF
|
|
ENDDO
|
|
DO J=1,NP
|
|
IF (INEW(J) .EQ. 1) THEN
|
|
WRITE(IOF, 5005) &
|
|
& J,XUSR(J),YUSR(J),WD(J)
|
|
5005 FORMAT('GNN',I6,2F14.3,F10.3)
|
|
ENDIF
|
|
ENDDO
|
|
DO J=1,NP
|
|
IF (INEW(J) .EQ. 1) THEN
|
|
IF(WIDTH(J) .GT. 0.) THEN
|
|
WRITE(IOF, 5006) &
|
|
& J, &
|
|
& WIDTH(J),SS1(J),SS2(J),WIDS(J)
|
|
5006 FORMAT('GWN',I6,1X,F9.1,1X,2F6.2,1X,F9.1)
|
|
ENDIF
|
|
ENDIF
|
|
ENDDO
|
|
|
|
|
|
return
|
|
end
|
|
|
|
subroutine wrtele(IOF,itr)
|
|
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
|
|
IOF=IOT
|
|
NVRT=2
|
|
if(itr .eq. 1) then
|
|
NEL=NE
|
|
NATT=2
|
|
IF(NOP(1,2) .EQ. 0) THEN
|
|
NVRT=3
|
|
ELSE
|
|
NVRT=6
|
|
ENDIF
|
|
write(IOF,6001) NEL,NVRT,NATT
|
|
DO N=1,NE
|
|
IF(NVRT .EQ. 3) THEN
|
|
WRITE(IOF,6002) N,(NOP(N,J),J=1,5,2),IMAT(N),THTA(N)
|
|
ELSE
|
|
WRITE(IOF,6003) N,(NOP(N,J),J=1,5,2),(NOP(N,J),J=2,6,2),IMAT(N),THTA(N)
|
|
ENDIF
|
|
ENDDO
|
|
else
|
|
NPL=NP
|
|
NATT=1
|
|
write(IOF,6001) NPL,NVRT,NATT
|
|
DO N=1,NPL
|
|
WRITE(IOF,6004) N,XUSR(N),YUSR(N),WD(N)
|
|
ENDDO
|
|
|
|
endif
|
|
6001 FORMAT(I6,I2,I2,I2)
|
|
6002 FORMAT(I6,3(' ',I6),I5,' ',F6.2)
|
|
6003 FORMAT(I6,6(' ',I6),I5,' ',F6.2)
|
|
6004 FORMAT(I6,2F16.6,F11.4)
|
|
return
|
|
end
|
|
|
|
|
|
SUBROUTINE RDRST(IENT,IUNIT)
|
|
|
|
USE BLK1MOD
|
|
! INCLUDE 'BLK1.COM'
|
|
CHARACTER*80 ALINE
|
|
|
|
IF(IENT .EQ. 1) THEN
|
|
! READ(IUNIT) IDUMMY1
|
|
READ(IUNIT) TITLE,NP,NE
|
|
! READ(IUNIT) IDUMMY1,IDUMMY2
|
|
READ(IUNIT) ISLP,IPRT,IPNN,IPEN,IPO,IRO,IPP,IRFN &
|
|
& ,IGEN,NXZL,NITST,ISCTXT,IFILL,IALTGM,NLAYD,xadded,yadded,ntempin
|
|
! READ(IUNIT) ,IDUMMY2,IDUMMY3
|
|
READ(IUNIT) HORIZ,VERT,XSALE,YSALE,XFACT,YFACT,AR,ANG
|
|
IPP=0
|
|
NTEMPIN=2
|
|
IF(IPP .GT. 0) THEN
|
|
! READ(IIN) IDUMMY3,IDUMMY4
|
|
READ(IIN) ALINE
|
|
ENDIF
|
|
|
|
ELSEIF(IENT .EQ. 2) THEN
|
|
! READ(IUNIT) IDUMMY4,IDUMMY5
|
|
READ(IUNIT) ((NOP(J,K),K=1,8),IMAT(J),THTA(J),J=1,NE)
|
|
DO J=1,NE
|
|
IF(IMAT(J) .NE. 0) THEN
|
|
NCN = 2
|
|
IF (NOP(J,3) .NE. 0) NCN = 3
|
|
IF (NOP(J,4) .NE. 0) NCN = 4
|
|
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .NE. 0) NCN = 5
|
|
IF (NOP(J,5) .NE. 0 .AND. NOP(J,4) .EQ. 0) NCN = 6
|
|
IF (NOP(J,6) .NE. 0) NCN = 6
|
|
IF (NOP(J,7) .NE. 0) NCN = 8
|
|
NCORN(J) = NCN
|
|
IESKP(J) = 0
|
|
ENDIF
|
|
ENDDO
|
|
ELSE
|
|
|
|
! READ(IUNIT) IDUMMY5,IDUMMY6
|
|
READ(IUNIT) &
|
|
& (XUSR(J),YUSR(J),WD(J),WIDTH(J),SS1(J),SS2(J),WIDS(J), &
|
|
& WIDBS(J),SSO(J),BS1(J),J=1,NP)
|
|
DO J=1,NP
|
|
CORD(J,1) = XUSR(J)
|
|
CORD(J,2) = YUSR(J)
|
|
INSKP(J)=0
|
|
INEW(J)=0
|
|
IF (CORD(J,1) .GT. VDX) THEN
|
|
INEW(J) = 1
|
|
ENDIF
|
|
ENDDO
|
|
! READ(IUNIT) IDUMMY5,IDUMMY6
|
|
READ(IUNIT) NLST
|
|
IF(NLST .GT. 0) THEN
|
|
! READ(IUNIT) IDUMMY5,IDUMMY6
|
|
READ(IUNIT) (LLIST(J),J=1,NLST), &
|
|
((ILIST(J,I),I=1,LLIST(J)),J=1,NLST)
|
|
ENDIF
|
|
|
|
! READ(IUNIT) IDUMMY5,IDUMMY6
|
|
READ(IUNIT) NENTRY,NLAYD,NCLM
|
|
if(nentry .eq. 0 .and. nlayd .eq. 0 .and. nclm .eq. 0) return
|
|
! READ(IUNIT) IDUMMY5,IDUMMY6
|
|
IF(NENTRY .GT. 0) THEN
|
|
! READ(IUNIT) IDUMMY5,IDUMMY6
|
|
READ(IUNIT) ((NEF(I,J),J=1,3),I=1,NENTRY)
|
|
ENDIF
|
|
IF(NLAYD .GT. 0) THEN
|
|
! READ(IUNIT) IDUMMY5,IDUMMY6
|
|
READ(IUNIT) (LAY(I),I=1,NP),((WTLAY(I,J),J=1,9),I=0,NP)
|
|
ENDIF
|
|
IF(NCLM .GT. 0) THEN
|
|
! READ(IUNIT) IDUMMY5,IDUMMY6
|
|
! NCLM=11
|
|
READ(IUNIT) ((ICCLN(I,J),J=1,350),I=1,NCLM)
|
|
ENDIF
|
|
ENDIF
|
|
RETURN
|
|
END
|
|
|
|
SUBROUTINE ADJUSTMAP(MAXPLL)
|
|
!
|
|
! Generate continuity lines
|
|
!
|
|
|
|
USE WINTERACTER
|
|
USE BLKMAP
|
|
include 'd.inc'
|
|
|
|
!
|
|
! Declare window-type and message variables
|
|
!
|
|
TYPE(WIN_STYLE) :: WINDOW
|
|
|
|
TYPE(WIN_MESSAGE) :: MESSAGE
|
|
|
|
integer :: NTYP,NLOCC
|
|
|
|
|
|
call wdialogload(IDD_SETMAXMAP)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogSelect(IDD_SETMAXMAP)
|
|
ierr=infoerror(1)
|
|
|
|
CALL WDialogPutINTEGER(IDF_INTEGER1,MAXPLL)
|
|
|
|
CALL WDialogShow(-1,-1,0,Modal)
|
|
ierr=infoerror(1)
|
|
|
|
do
|
|
!
|
|
IF (WInfoDialog(ExitButton) .EQ. IDOK) THEN
|
|
|
|
CALL WDialogGetINTEGER(IDF_INTEGER1,MAXPLL)
|
|
|
|
GO TO 100
|
|
ENDIF
|
|
|
|
enddo
|
|
|
|
100 CONTINUE
|
|
return
|
|
end
|
|
|
|
SUBROUTINE RDESRI(alin,k,j)
|
|
use blkmap
|
|
use blk1mod
|
|
real*8 xorig,yorig,cellsize
|
|
character*80 alin
|
|
! READ HEADERS
|
|
read(alin(6:80),*) ncols
|
|
READ(IMP,'(A80)') ALIN
|
|
read(alin(6:80),*) nrows
|
|
READ(IMP,'(A80)') ALIN
|
|
read(alin(10:80),*) xorig
|
|
READ(IMP,'(A80)') ALIN
|
|
read(alin(10:80),*) yorig
|
|
READ(IMP,'(A80)') ALIN
|
|
read(alin(9:80),*) cellsize
|
|
READ(IMP,'(A80)') ALIN
|
|
read(alin(13:80),*) xnodat
|
|
ntot=ncols*nrows
|
|
read(imp,'(10f12.0)') (val(i),i=1,ntot)
|
|
ict=0
|
|
ikp=0
|
|
do n=1,nrows
|
|
ytemp=cellsize*(n-1)+yorig
|
|
do m=1,ncols
|
|
ict=ict+1
|
|
if(val(ict) .ne. xnodat) then
|
|
xtemp=cellsize*(m-1)+xorig
|
|
ikp=ikp+1
|
|
xmap(ikp)=xtemp
|
|
ymap(ikp)=ytemp
|
|
cmap(ikp,1)=xtemp
|
|
cmap(ikp,2)=ytemp
|
|
val(ikp)=val(ict)
|
|
endif
|
|
enddo
|
|
LINTYP(1)=2
|
|
k=2
|
|
j=ikp
|
|
enddo
|
|
RETURN
|
|
END
|
|
|
|
|
|
SUBROUTINE PARSELIN(DLININ,DLIN,ICLON,NCHARBL)
|
|
CHARACTER*150 DLIN,DLININ
|
|
CHARACTER*1 CTYPE(6)
|
|
INTEGER ICLON
|
|
DATA CTYPE/' ',',','\',':','/','&'/
|
|
IBAS=0
|
|
IPREV=1
|
|
ICLON=0
|
|
NCHARBL=0
|
|
DO K=1,75
|
|
DLIN(K:K)=CTYPE(1)
|
|
ENDDO
|
|
DO K=1,75
|
|
! IF DLININ = '&' RETURN
|
|
|
|
IF(DLININ(K:K) .EQ. CTYPE(6)) THEN
|
|
IF(IBAS .EQ. 0) RETURN
|
|
IF(DLIN(IBAS:IBAS) .EQ. CTYPE(2)) THEN
|
|
DLIN(IBAS:IBAS)= CTYPE(1)
|
|
ELSE
|
|
IBAS=IBAS+1
|
|
DLIN(IBAS:IBAS) =CTYPE(1)
|
|
NCHARBL=NCHARBL+1
|
|
ENDIF
|
|
|
|
RETURN
|
|
ENDIF
|
|
! IF(DLININ = BLANK
|
|
|
|
IF(DLININ(K:K) .EQ. CTYPE(1)) THEN
|
|
|
|
! TEST FOR PREVIOUS BLANK IF SO MOVE ON
|
|
|
|
IF(IPREV .EQ. 1) GO TO 200
|
|
|
|
! IF NO PREVIOUS THEN WE HAVE AN END OF CHARACTER STREAM ADD A COMMA TO DLIN
|
|
IPREV=1
|
|
IF(DLIN(IBAS:IBAS) .NE. CTYPE(2)) THEN
|
|
IBAS=IBAS+1
|
|
DLIN(IBAS:IBAS)=CTYPE(2)
|
|
NCHARBL=NCHARBL+1
|
|
ENDIF
|
|
ELSE
|
|
|
|
! WE HAVE NUMBER OR A COMMA OR \ OR / CHARACTER
|
|
|
|
DO J=2,5
|
|
IF(DLININ(K:K) .EQ. CTYPE(J)) THEN
|
|
|
|
! FOUND SOMETHING ADD A COMMA
|
|
|
|
IPREV=0
|
|
IBAS=IBAS+1
|
|
IF(J .EQ. 4) THEN
|
|
ICLON=1
|
|
ENDIF
|
|
DLIN(IBAS:IBAS)=CTYPE(2)
|
|
NCHARBL=NCHARBL+1
|
|
GO TO 100
|
|
ENDIF
|
|
ENDDO
|
|
|
|
! NOTHING FOUND MUST BE LETTER OR NUMBER COPY IT OVER
|
|
|
|
IPREV=0
|
|
IBAS=IBAS+1
|
|
DLIN(IBAS:IBAS)=DLININ(K:K)
|
|
! MOVE ON TO NEXT CHARACTER
|
|
|
|
100 CONTINUE
|
|
ENDIF
|
|
200 ENDDO
|
|
RETURN
|
|
END
|
|
|