home *** CD-ROM | disk | FTP | other *** search
/ ftp.ee.lbl.gov / 2014.05.ftp.ee.lbl.gov.tar / ftp.ee.lbl.gov / mtrek.shar.Z / mtrek.shar / yesno.ftn < prev    next >
Text File  |  1990-04-02  |  750b  |  44 lines
  1.     SUBROUTINE YESNO(FLAG,VALID)
  2.  
  3.     LOGICAL*1 FLAG,VALID
  4.     BYTE YES(3),NO(3),ANSWER(3)
  5.     DATA YES/'Y','E','S'/
  6.     DATA NO/'N','O',' '/
  7.  
  8.     VALID=.TRUE.
  9.     FLAG=.FALSE.
  10.     READ(1,10002,END=800,ERR=10020)NCHRS,(ANSWER(I),I=1,3)
  11. 10002    FORMAT(Q,3A1)
  12.     IF(NCHRS.EQ.0)GOTO 10001
  13.     IF(NCHRS.GT.3)NCHRS=3
  14. C
  15. C    Make lower case characters upper case
  16. C
  17.     DO 10004 I=1,NCHRS
  18.     IF((ANSWER(I).LE.'a').OR.(ANSWER(I).GE.'z'))GOTO 10004
  19.     ANSWER(I)=ANSWER(I)-"40
  20. 10004    CONTINUE
  21. C
  22. C    Check for yes
  23. C
  24.     DO 10005 I=1,NCHRS
  25.     IF(ANSWER(I).NE.YES(I))GOTO 10011
  26. 10005    CONTINUE
  27.     FLAG=.TRUE.
  28.     GOTO 10001
  29. C
  30. C    Check for a no
  31. C
  32. 10011    DO 10007 I=1,NCHRS
  33.     IF(ANSWER(I).NE.NO(I))GOTO 10020
  34. 10007    CONTINUE
  35.     GOTO 10001
  36. C
  37. C    Incorrect response
  38. C
  39. 10020    VALID=.FALSE.
  40. 10001    RETURN
  41. 800    CONTINUE
  42.     CALL EXIT
  43.     END
  44.