!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' .OR. ID8(1:8) .EQ. 'MESH2D') 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 .and. ID(1:2) .EQ. 'NS') THEN NLST=0 ILIST=0 KST=1 ENDIF DO JJ=1,150 DLIN1(JJ:JJ)=' ' ENDDO 70 CONTINUE READ(IUNIT,'(A3,A150)', END=400) ID,DLIN1 if(ID(1:2) .NE. 'ND' .AND. IGFG .EQ. 3) GO TO 70 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) THEN IMP=IMPP JSTT=JLINT KSTT=KLINT ENDIF 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 NGRTYP=1 READ(IMP,*) NCOLS1,NROWS1 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,*) XXORG,XXTOP,YYORG,YYTOP READ(IMP,*) DD1,DD2 CELLSIZX=(XXTOP-XXORG)/(NCOLS1-1) CELLSIZY=(YYTOP-YYORG)/(NROWS1-1) ANODAT=1.E36 II=0 jj=0 IGUNIT=203 XXORG=XXORG+CELLSIZX/2. YYORG=YYORG+CELLSIZY/2. DO J=1,NROWS1 YCOL(J)=CELLSIZY*(J-1)+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) do i=1,ncols1 if(vallin(i) .gt. anodat) vallin(i)=-9999. enddo WRITE(203) (VALLIN(I),I=1,NCOLS1) if(j .gt. 1 .AND. J .LT. NROWS1) 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*(J-1)+YYORG CMAP(JJ,1)=XMAP(JJ) CMAP(JJ,2)=YMAP(JJ) val(jj)=0. if(vallin(i) .lt. anodat/10.) VAL(JJ)=VALLIN(I) ENDDO ENDDO ! 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 NGRTYP=2 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' .and. 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) do i=1,ncols1 if(anodat .gt. 0) then if(vallin(i) .gt. anodat/10.) vallin(i)=-9999. else if(vallin(i) .le. anodat+100.) vallin(i)=-9999. endif enddo WRITE(203) (VALLIN(I),I=1,NCOLS1) if(j .gt. 1 .AND. J .LT. NROWS1) 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)=0. if(vallin(i) .lt. anodat/10.) VAL(JJ)=VALLIN(I) ENDDO ENDDO ENDIF REWIND(IGUNIT) MAXPTS=JJ+1 XMAP(MAXPTS+1)= VOID jlint=jj+1 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 .and. IMP .NE. 113) 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 NUMMAT=0 DO ICOUNTC=1,700000 DO JJ=1,150 DLIN1(JJ:JJ)=' ' ENDDO READ(IUNIT,'(A3,A150)', END=175) ID,DLIN1 IF(ID(1:3) .EQ. 'NUM') THEN READ(DLIN1(20:40),*) NUMMAT NUMMAT=NUMMAT-1 ENDIF IF(ID(1:2) .EQ. 'ND') CYCLE 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+NUMMAT GO TO 90 ELSEIF(ID .EQ. 'E4Q') THEN ICOUNT=5+NUMMAT GO TO 90 ELSEIF(ID .EQ. 'E6T') THEN ICOUNT=7+NUMMAT GO TO 90 ELSEIF(ID .EQ. 'E8Q') THEN ICOUNT=9+NUMMAT 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. 3) THEN READ(DLIN1,*) J, (NTMP(K),K=1,5,2) NTMP(9)=1 NTMP(2)=0 NTMP(4)=0 NTMP(6)=0 NTMP(7)=0 NTMP(8)=0 ELSEIF(ICOUNT .EQ. 4 .AND. NUMMAT .EQ. 0) 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. 4 .AND. NUMMAT .LT. 0) THEN READ(DLIN1,*) J, (NTMP(K),K=1,7,2) NTMP(9)=1 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 ISWW=1 CALL KCON(ISWW) 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) ! write(156,8888) klint,jlint,(j,xmap(j),ymap(j),val(j),j=1,jlint) ! write(156,8887)& ! & ,(k,lintyp(k),k=1,klint) !8888 format('start',2i5/(i6,3e15.6)) !8887 format('lin'/(2i8)) 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