SUBROUTINE GETCML(BUFFER,PROMPT,LENGTH,MAXLEN,EOF,LUN,NOCLOS, 00150 1 COMNTS) 00151 IMPLICIT NONE 00155 INCLUDE ' 32766 .FID/NOLIST' 00155 INCLUDE '($FORIOSDEF)/NOLIST' !871029 00157 BYTE BUFFER(1) !EXT, 00159 INTEGER*2 COMNTS !EXT, 00160 CHARACTER*4 DEF_EXT(2) !LOC, '.COM', '.CMD' !850805 00161 LOGICAL*1 DFLT_PROMPT !LOC, 00162 LOGICAL*2 EOF !EXT, 00163 LOGICAL*1 EOF_ON_FILE !LOC, 00164 LOGICAL*1 FST_PASS !LOC, 00165 INTEGER*2 I !LOC, 00166 BYTE IBUFF(161) !LOC, 00167 INTEGER*2 INLVL !LOC, level of cmd file; 0==>TI: 00168 INTEGER*2 INPUT_FROM_TI !/DVGCML/, see note 4 00169 INTEGER*4 IOST !LOC, F77 IO status !871029 00170 INTEGER*2 J !LOC, scratch 00171 INTEGER*2 LENGTH !EXT, 00172 INTEGER*2 LUN !EXT, ignored !860424 00173 INTEGER*4 LUNDSK(3) !LOC, LUN for disk input files !860424 00174 INTEGER*4 LUNTI !LOC, LUN for TI: input !860424 00175 INTEGER*2 MAP !LOC, 00176 INTEGER*2 MAXCHAR !LOC, 00177 INTEGER*2 MAXLEN !EXT, 00178 INTEGER*2 NARGS !LOC, 00179 INTEGER*2 NOCLOS !EXT, ignored !860424 00180 LOGICAL*1 NOINPUT !LOC, 00181 INTEGER*2 NPRMPT !LOC, 00182 LOGICAL*1 NRML_PROMPT !LOC, 00183 LOGICAL*1 NULL_INPUT_OK !LOC, 00184 BYTE PROMPT(1) !EXT, 00185 LOGICAL*1 RTN_CMNT !LOC, 00186 BYTE SPACE !LOC, 00187 LOGICAL*1 TEST !LOC, scratch 00188 LOGICAL*1 TI_CTRLZ !LOC, 00189 LOGICAL*1 WAS_CMD_LN !LOC, 00190 COMMON /DVGCML/ INPUT_FROM_TI 00192 DATA INLVL/0/,TI_CTRLZ/.FALSE./ 00194 DATA FST_PASS/.TRUE./,SPACE/1H / 00195 DATA DEF_EXT/'.COM','.CMD'/ !850805 00197 DATA LUNTI/0/, LUNDSK/3*0/ !860424 00199 ASSIGN 32757 TO I32758 00203 GO TO 32758 00203 32757 IF(.NOT.FST_PASS.AND.WAS_CMD_LN.AND.INLVL.EQ.0)THEN 00208 ASSIGN 32755 TO I32756 00209 GO TO 32756 00209 32755 CONTINUE 00210 ENDIF 00210 NOINPUT=.TRUE. 00212 I32754=.TRUE. 00213 DOWHILE(((I32754)).OR.(NOINPUT)) 00213 I32754=.FALSE. 00213 EOF_ON_FILE=.FALSE. 00214 IF(INLVL.EQ.0)THEN 00218 IF(FST_PASS)THEN 00219 ASSIGN 32752 TO I32753 00219 GO TO 32753 00219 32752 CONTINUE 00220 ELSE 00220 ASSIGN 32750 TO I32751 00221 GO TO 32751 00221 32750 ASSIGN 32748 TO I32749 00222 GO TO 32749 00222 32748 CONTINUE 00223 ENDIF 00223 ELSE 00225 ASSIGN 32746 TO I32747 00225 GO TO 32747 00225 32746 CONTINUE 00225 ENDIF 00225 IF(LENGTH.GT.0 .AND. .NOT.RTN_CMNT)THEN 00227 ASSIGN 32744 TO I32745 00227 GO TO 32745 00227 32744 CONTINUE 00227 ENDIF 00227 IF(FST_PASS)THEN 00232 FST_PASS=.FALSE. 00233 IF(WAS_CMD_LN)THEN 00234 IF(IBUFF(1).EQ.1H@)THEN 00235 ASSIGN 32742 TO I32743 00235 GO TO 32743 00235 32742 CONTINUE 00236 ELSE 00236 NOINPUT=.FALSE. 00236 ENDIF 00236 ENDIF 00237 ELSEIF(TI_CTRLZ)THEN 00239 NOINPUT=.FALSE. 00239 ELSEIF(EOF_ON_FILE)THEN 00240 ASSIGN 32740 TO I32741 00240 GO TO 32741 00240 32740 CONTINUE 00241 ELSEIF(LENGTH.EQ.0.AND..NOT.NULL_INPUT_OK)THEN 00241 ELSEIF(LENGTH.GT.MAXCHAR)THEN 00242 ASSIGN 32738 TO I32739 00242 GO TO 32739 00242 32738 CONTINUE 00243 ELSEIF(IBUFF(1).EQ.1H;.AND..NOT.RTN_CMNT)THEN 00243 ELSEIF(IBUFF(1).EQ.1H@)THEN 00244 ASSIGN 32737 TO I32743 00244 GO TO 32743 00244 32737 CONTINUE 00245 ELSE 00245 NOINPUT=.FALSE. 00245 ENDIF 00246 ENDDO 00247 IF(LENGTH.GT.0)THEN 00249 DO I=1,LENGTH 00250 BUFFER(I)=IBUFF(I) 00250 ENDDO 00250 DO I=1,LENGTH 00252 IF(BUFFER(I).GE.'a' .AND. BUFFER(I).LE.'z')THEN 00253 BUFFER(I) = BUFFER(I)-'20'X 00254 ENDIF 00255 ENDDO 00256 ENDIF 00258 RETURN 00259 32758 CONTINUE 00261 CALL ARGS(NARGS,MAP) 00265 IF(NARGS.LT.3)THEN 00266 TYPE 1 00267 1 FORMAT(' GETCML CALL MUST HAVE AT LEAST 3 ARGUMENTS') 00268 CALL EXIT 00269 ENDIF 00270 IF(((MAP.AND."1).EQ.0).OR.((MAP.AND."4).EQ.0))THEN 00272 TYPE 2 00273 2 FORMAT(' GETCML CALL MUST GIVE 1ST AND 3RD ARGUMENTS') 00274 CALL EXIT 00275 ENDIF 00276 IF((MAP.AND."2).NE.0)THEN 00278 DFLT_PROMPT=.FALSE. 00279 NPRMPT=1 00280 DOWHILE(.NOT.(PROMPT(NPRMPT).EQ.0)) 00281 NPRMPT=NPRMPT+1 00281 ENDDO 00281 NPRMPT=NPRMPT-1 00282 IF(NPRMPT.EQ.0)THEN 00283 DFLT_PROMPT=.TRUE. 00283 ELSE 00284 IF(NPRMPT.EQ.3)THEN 00285 NRML_PROMPT=.TRUE. 00285 ELSE 00286 NRML_PROMPT=.FALSE. 00286 ENDIF 00286 ENDIF 00287 ELSE 00289 DFLT_PROMPT=.TRUE. 00289 ENDIF 00289 NULL_INPUT_OK=.FALSE. 00291 IF(NARGS.GE.4.AND.((MAP.AND."10).NE.0))THEN 00292 IF(MAXLEN.GT.0)THEN 00294 MAXCHAR=MAXLEN 00294 ELSEIF(MAXLEN.EQ.0)THEN 00295 MAXCHAR=80 00295 ELSE 00296 NULL_INPUT_OK=.TRUE. 00297 MAXCHAR=-MAXLEN 00298 ENDIF 00300 ELSE 00302 MAXCHAR=80 00302 ENDIF 00302 IF(MAXCHAR.GT.160)THEN 00303 TYPE*,'GETCML called with |MAXLEN|>160' 00304 CALL EXIT 00305 ENDIF 00306 IF(NARGS.GE.5.AND.((MAP.AND."20).NE.0))EOF=.FALSE. 00308 TEST = ((MAP.AND."200).NE.0) .AND. (NARGS.GE.8) !850410 00314 IF((TEST) .AND. (COMNTS.NE.0))THEN 00315 RTN_CMNT=.TRUE. 00316 ELSE 00318 RTN_CMNT=.FALSE. 00318 ENDIF 00318 GO TO I32758 00319 32753 CONTINUE 00321 CALL GETMCR(IBUFF,LENGTH) 00325 D TYPE *,' GETCML ',IBUFF,LENGTH 00326 IF(LENGTH.GT.0)THEN 00327 I=1 00331 DOWHILE(.NOT.(IBUFF(I).EQ.SPACE.OR.I.EQ.LENGTH)) 00332 I=I+1 00332 ENDDO 00332 ENDIF 00333 IF(LENGTH.LT.0.OR.I.EQ.LENGTH)THEN 00335 LENGTH=0 00339 WAS_CMD_LN=.FALSE. 00340 ELSEIF(LENGTH-I.GT.MAXCHAR)THEN 00342 ASSIGN 32736 TO I32739 00343 GO TO 32739 00343 32736 WAS_CMD_LN=.FALSE. 00344 ELSE 00346 LENGTH=LENGTH-I 00347 DO J=1,LENGTH 00348 IBUFF(J)=IBUFF(J+I) 00348 ENDDO 00348 IBUFF(LENGTH+1) = 0 !860424 00349 WAS_CMD_LN=.TRUE. 00350 INPUT_FROM_TI = 2 00351 ENDIF 00353 GO TO I32753 00354 32741 CONTINUE 00356 INLVL=INLVL-1 00360 IF(.NOT.FST_PASS.AND.WAS_CMD_LN.AND.INLVL.EQ.0)THEN 00364 ASSIGN 32735 TO I32756 00365 GO TO 32756 00365 32735 CONTINUE 00366 ENDIF 00366 GO TO I32741 00367 32756 CONTINUE 00369 IF((NARGS.GE.5).AND.((MAP.AND."20).NE.0))THEN 00374 LENGTH=0 00375 EOF=.TRUE. 00376 RETURN 00377 4000 CONTINUE !GET RID OF FORTRAN "NO PATH TO STATEMENT MSG" 00378 ELSE 00380 CALL EXIT 00381 ENDIF 00382 GO TO I32756 00383 32739 CONTINUE 00385 TYPE 10,(IBUFF(I),I=1,MAXCHAR) 00386 10 FORMAT(' GETCML--INPUT LINE TOO LONG; LINE IGNORED',/,(1X,70A1)) 00387 GO TO I32739 00388 32743 CONTINUE 00390 IF(INLVL.EQ.3)THEN 00391 TYPE 11 00392 11 FORMAT(' GETCML--TOO MANY LEVELS OF INDIRECT INPUT FILES') 00393 CALL EXIT 00394 ELSE 00396 INLVL=INLVL+1 00397 J = 1 !860424 00401 INQUIRE (FILE=IBUFF(2),EXIST=TEST, !850805 00402 1 DEFAULTFILE=DEF_EXT(J)) !860424 00403 IF (.NOT.TEST) J=2 !Try .CMD !860424 00405 IF (LUNDSK(INLVL).EQ.0) THEN !860424 00409 CALL LIB$GET_LUN (LUNDSK(INLVL)) !860424 00410 IF (LUNDSK(INLVL).LT.1) THEN !860424 00411 TYPE*,'GETCML--No luns available for level',INLVL, !860424 00412 1 ' Indirect input file' !860424 00413 CALL EXIT !860424 00414 ENDIF !860424 00415 ENDIF !860424 00416 OPEN (UNIT=LUNDSK(INLVL),NAME=IBUFF(2),READONLY, !860424 00418 1 RECORDTYPE='VARIABLE',FORM='UNFORMATTED', !871029 00419 1 DEFAULTFILE=DEF_EXT(J),ACCESS='SEQUENTIAL', !860424 00420 2 ERR=2000,TYPE='OLD') !860424 00421 INPUT_FROM_TI = 1 00423 IF (.FALSE.) THEN !860424 00425 2000 TYPE 8,(IBUFF(I),I=2,LENGTH) !860424 00426 8 FORMAT(' GETCML CANNOT OPEN INDIRECT INPUT FILE ', !860424 00427 1 /,(1X,70A1)) !860424 00428 EOF_ON_FILE=.TRUE. !860424 00429 ENDIF !860424 00430 ENDIF 00431 GO TO I32743 00432 32747 CONTINUE 00434 READ (LUNDSK(INLVL),IOSTAT=IOST) IBUFF !871029 00436 IF (IOST.EQ.-1) THEN !871029 00437 EOF_ON_FILE=.TRUE. !871029 00438 CLOSE(UNIT=LUNDSK(INLVL)) !871029 00439 ELSEIF (IOST.EQ.0 .OR. IOST.EQ.FOR$IOS_INPSTAREQ) THEN !871029 00440 IOST = 0 !"Data underrun" is ok !871029 00441 CALL RDLEN(LUNDSK(INLVL),LENGTH) !871029 00442 INPUT_FROM_TI = 1 00443 ELSE !871029 00444 TYPE*,'GETCML--Command file F77 read error=',IOST !871029 00445 CALL EXIT !871029 00446 ENDIF 00447 DOWHILE(IBUFF(LENGTH).EQ.1H- .AND. LENGTH.LT.161 .AND. IOST.EQ.0) 00449 READ(LUNDSK(INLVL),IOSTAT=IOST)(IBUFF(I),I=LENGTH,161) !871029 00453 IF (IOST.EQ.-1) THEN !871029 00454 EOF_ON_FILE=.TRUE. !871029 00455 CLOSE(UNIT=LUNDSK(INLVL)) !871029 00456 ELSEIF (IOST.EQ.0 .OR. IOST.EQ.FOR$IOS_INPSTAREQ) THEN !871029 00457 IOST = 0 !"Data underrun" is ok !871029 00458 CALL RDLEN(LUNDSK(INLVL),J) !871029 00459 LENGTH=LENGTH-1+J !Dont count the - 00460 ELSE !871029 00461 TYPE*,'GETCML--Command file F77 read error=',IOST !871029 00462 CALL EXIT !871029 00463 ENDIF 00464 ENDDO 00466 GO TO I32747 00468 32749 CONTINUE 00470 IF (LUNTI.EQ.0) THEN !860424 00474 CALL LIB$GET_LUN(LUNTI) !860424 00476 IF (LUNTI.LT.1) THEN !860424 00477 TYPE*,'GETCML--No LUNs available for TI: input' !860424 00478 CALL EXIT !860424 00479 ENDIF !860424 00480 OPEN (UNIT=LUNTI,NAME='SYS$INPUT',STATUS='UNKNOWN', !860424 00482 1 FORM='UNFORMATTED',RECORDTYPE='VARIABLE') !871029 00483 ENDIF !860424 00484 READ (LUNTI,IOSTAT=IOST)IBUFF !871029 00486 IF (IOST.EQ.-1) THEN !871029 00487 ASSIGN 32734 TO I32756 00491 GO TO 32756 00491 32734 CONTINUE 00492 ELSEIF (IOST.EQ.0 .OR. IOST.EQ.FOR$IOS_INPSTAREQ) THEN !871029 00492 IOST = 0 !"Data underrun" is ok !871029 00493 CALL RDLEN(LUNTI,LENGTH) !871029 00494 INPUT_FROM_TI = 2 !860424 00495 ELSE !871029 00496 TYPE*,'GETCML--TI: F77 read error=',IOST !871029 00497 CALL EXIT !871029 00498 ENDIF !871029 00499 DOWHILE(IBUFF(LENGTH).EQ.1H- .AND. LENGTH.LT.161 .AND. IOST.EQ.0) 00501 ASSIGN 32733 TO I32751 00505 GO TO 32751 00505 32733 READ (LUNTI,IOSTAT=IOST) (IBUFF(I),I=LENGTH,161) !871029 00506 IF (IOST.EQ.-1) THEN !871029 00507 ASSIGN 32732 TO I32756 00511 GO TO 32756 00511 32732 CONTINUE 00512 ELSEIF (IOST.EQ.0 .OR. IOST.EQ.FOR$IOS_INPSTAREQ) THEN !871029 00512 IOST = 0 !"Data underrun" is ok !871029 00513 CALL RDLEN(LUNTI,J) !871029 00514 LENGTH = LENGTH-1+J !dont count the - 00515 ELSE !871029 00516 TYPE*,'GETCML--TI: F77 read error=',IOST !871029 00517 CALL EXIT !871029 00518 ENDIF !871029 00519 ENDDO 00521 GO TO I32749 00523 32745 CONTINUE 00525 I = LENGTH 00529 DOWHILE(I.GT.0 .AND. IBUFF(I).NE.1H!) 00531 I=I-1 00531 ENDDO 00531 IF (I.GT.0) LENGTH=I-1 00533 GO TO I32745 00534 32751 CONTINUE 00536 IF(DFLT_PROMPT)THEN 00538 TYPE 3 00539 3 FORMAT('$ >') 00540 ELSEIF(NRML_PROMPT)THEN 00542 TYPE 4,(PROMPT(I),I=1,3) 00543 4 FORMAT('$',3A1,'>') 00544 ELSE 00546 TYPE 5,(PROMPT(I),I=1,NPRMPT) 00547 5 FORMAT('$',80A1) 00548 ENDIF 00550 GO TO I32751 00551 END 00552