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.

112 lines
2.6 KiB
Fortran

SUBROUTINE RDRM1(IFILE,NPTEMP,NETEMP,IMIDS)
SAVE
REAL*8 CX,CY
CHARACTER DLINE*140,ID1*3,BLANK*20
DIMENSION ILN(8)
data blank/' '/
REWIND (IFILE)
READ(ifile,'(A80)') TITLE
READ(IFILE,'(100X,I5)') IFORM1
READ(IFILE,'(A80)') DLINE(1:80)
IMIDS=0
NP=0
NE=0
NPTEMP=0
NETEMP=0
100 CALL GINPT1(IFILE,DLINE)
!ipk feb12 add format test
IF(MOD(IFORM1,2) .EQ. 1) THEN
READ(DLINE,'(10I6,F10.3,I6)') J,ILN,IMT,EDIR,INU
ELSE
READ(DLINE,'(10I5,F10.3,I5)') J,ILN,IMT,EDIR,INU
ENDIF
IF(ILN(1) .EQ. 0 .AND. (J .EQ. 9999 .OR. J .EQ. 99999)) THEN
GO TO 120
ELSE
IF(ILN(7) .NE. 0) THEN
NCN=8
ELSEIF(ILN(5) .NE. 0) THEN
NCN=6
ELSEIF(ILN(3) .NE. 0) THEN
NCN=3
ENDIF
DO K=1,NCN
NPTEMP=MAX(NPTEMP,ILN(K))
NETEMP=MAX(NETEMP,J)
IF(MOD(K,2) .EQ. 0 .AND. ILN(K) .EQ. 0) IMIDS=1
ENDDO
GO TO 100
ENDIF
120 continue
CALL GINPT1(IFILE,DLINE)
IF(IFORM1 .LT. 2) THEN
READ(DLINE,'(I10,9F10.0,I10,F10.0)') J, CX, CY, BELEV,&
WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11
ELSE
! do kct=1,140
! if(dline(kct:kct) .eq. '*') then
do kcl=61,140
dline(kcl:kcl)=' '
enddo
! go to 8888
! endif
! enddo
!8888 continue
READ(DLINE,'(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
dline(kcl:kcl)=' '
enddo
READ(DLINE,'(I10,2F20.0,7F10.0,I10,F10.0)') J, CX, CY, BELEV,&
WDTHX,SS1X,SS2X,WDSX,WEL,SSSO,LOCK1,BS11
8889 continue
ENDIF
IF(DLINE(11:30) .eq. blank .AND. (J .EQ. 9999 .OR. J .EQ. 99999)) THEN
GO TO 140
ELSE
NPTEMP=MAX(NPTEMP,J)
GO TO 120
ENDIF
140 CONTINUE
REWIND(IFILE)
RETURN
END
SUBROUTINE GINPT1(IIN,DLIN)
CHARACTER DLIN*140
100 CONTINUE
READ(IIN,7000) DLIN
!IPK SEP08 write(75,7000) dlin
7000 FORMAT(A140)
do i=1,140
if(dlin(i:i) .eq. char(9)) go to 200
enddo
RETURN
200 continue
!IPK SEP04
CLOSE(75)
OPEN(75,file='ERROR.OUT')
write(*,*) 'Error Tab character found in the following line'
write(75,*) 'Error Tab character found in the following line'
write(75,7000) dlin
write(*,7000) dlin
stop
END