home *** CD-ROM | disk | FTP | other *** search
/ NetNews Usenet Archive 1992 #26 / NN_1992_26.iso / spool / comp / lang / fortran / 4295 < prev    next >
Encoding:
Internet Message Format  |  1992-11-12  |  5.8 KB
  1. Xref: sparky comp.lang.fortran:4295 comp.os.vms:17842
  2. Path: sparky!uunet!dtix!darwin.sura.net!Sirius.dfn.de!zam103!isi001.dnet.kfa-juelich.de!system
  3. From: system@isi001.dnet.kfa-juelich.de
  4. Newsgroups: comp.lang.fortran,comp.os.vms
  5. Subject: Re: Turning VAX FORTRAN IOSTAT returns into VMS status codes?
  6. Message-ID: <1992Nov12.135007@isi001.dnet.kfa-juelich.de>
  7. Date: 12 Nov 92 13:34:23 GMT
  8. References: <2b022ab8.3aaa@lhn.gns.cri.nz>
  9. Sender: news@zam103.zam.kfa-juelich.de
  10. Reply-To: system@isi001.dnet.kfa-juelich.de ()
  11. Followup-To: comp.lang.fortran
  12. Organization: Forschungszentrum (KFA) Juelich GmbH, Germany
  13. Lines: 220
  14. Nntp-Posting-Host: isi001
  15.  
  16. In article <2b022ab8.3aaa@lhn.gns.cri.nz>, mdlcpgs@lhn.gns.cri.nz writes:
  17. |>Path:
  18. |
  19. zam103!Sirius.dfn.de!mailgzrz.TU-Berlin.DE!math.fu-berlin.de!news.belwue
  20. e.de!ira.uka.de!yale.edu!qt.cs.utexas.edu!cs.utexas.edu!wupost!waikato.a
  21. ac.nz!comp.vuw.ac.nz!am.dsir.govt.nz!lhn.gns.cri.nz
  22. |>From: mdlcpgs@lhn.gns.cri.nz
  23. |>Newsgroups: comp.lang.fortran,comp.os.vms
  24. |>Subject: Turning VAX FORTRAN IOSTAT returns into VMS status codes?
  25. |>Message-ID: <2b022ab8.3aaa@lhn.gns.cri.nz>
  26. |>Date: 11 Nov 92 21:58:16 GMT
  27. |>Organization: Institute of Gelogical & Nuclear Sciences, New Zealand.
  28. |>Lines: 6
  29. |>Xref: zam103 comp.lang.fortran:4668 comp.os.vms:19584
  30. |>
  31. |>Hi. I wonder if anyone can tell me how to turn a VAX FORTRAN
  32. |>IOSTAT status return value into a VMS status for signalling
  33. |>by LIB$SIGNAL?  I cant in this application use ERRSNS because ...
  34. |>
  35. Hi Phil,
  36. I'll give you an exaple below
  37.  
  38. ------------------ cut here ---------------------
  39. c
  40. c
  41.     program mbxqio
  42. c
  43. c    this program illustrates handling terminal input
  44. c    using terminal/mailbox interaction. when
  45. c    something is typed at a terminal information is
  46. c    written to its associated mailbox. this
  47. c    triggers an AST which notifies the program of
  48. c    the input.
  49. c
  50.     implicit integer*4 (a-z)
  51.     integer*2     ttchan, mbxchan
  52.     character    mbxname*7 /'mailbox'/,    ttname*11 /'sys$command'/
  53.     character*80 ttbuf,inp
  54.     integer*2 iosb(4)
  55.     real*8 time
  56.     logical*1 isr
  57.     common ttchan,iosb,ttbuf
  58.     common /test/ i,isr
  59.     external isr_timer
  60.     inp = '0 00:00:10'
  61.     status = sys$bintim(inp,time)
  62.     last3 = %loc(isr_timer)
  63. c
  64. c    create mailbox and assign a channel to it
  65. c
  66.     status = sys$crembx(,mbxchan,,,,,mbxname)
  67.     if( .not. status ) call lib$stop(%val(status))
  68. c
  69. c    associate the mailbox with 'term1'
  70. c
  71.     status = sys$assign(ttname, ttchan,, mbxname)
  72.     if( .not. status ) call lib$stop(%val(status))
  73. c
  74. c    open the terminal
  75. c
  76.     open (unit=1, file=ttname, status='old')
  77. c
  78. c    enable the mailbox AST
  79. c
  80. c    do i =1,3        !CAUTION: Interrupts will be queued
  81.     call enable1 (mbxchan)
  82. c    end do
  83. c
  84. c    hibernate the process
  85. c
  86.     isr = .false.
  87.     status = sys$setimr(,time,%val(last3),)
  88. c    i = 0
  89. c10    continue
  90. c    i = i + 1
  91. c    go to 10
  92.     status = sys$hiber()
  93.     if( .not. status ) call lib$stop(%val(status))
  94.     status = sys$cancel(%val(ttchan))
  95.     call lib$signal(%val(status))
  96. c
  97. c
  98. c    call enable1( mbxchan)
  99.     write(6,'('' interrupt enabled'')')
  100.     call disable1 (mbxchan)
  101.     write(6,'('' interrupt disabled'')')
  102. c
  103. c    hibernate the process
  104. c
  105.     isr = .false.
  106.     status = sys$setimr(,time,%val(last3),)
  107.     status = sys$hiber()
  108.     if( .not. status ) call lib$stop(%val(status))
  109. c
  110.     stop
  111.     end
  112.     subroutine enable1(mbxchan)
  113. c
  114. c    this subroutine enables a write attention AST
  115. c    for mailbox associated with the terminal.
  116. c
  117.     implicit integer*4 (a-z)
  118.     integer*2    mbxchan
  119.     external ast1
  120.     include '($iodef)'
  121. c
  122.     wrt_ast = io$_setmode .or. io$m_wrtattn
  123.     io1 = io$_setmode
  124.     io2 = io$m_wrtattn
  125. c
  126. c    enable AST1
  127. c
  128.     status = sys$qiow(,%val(mbxchan),%val(wrt_ast),,,,ast1,mbxchan,,,,)
  129.     if( .not. status ) call lib$stop(%val(status))
  130.     return
  131.     end
  132.     subroutine ast1(mbxchan)
  133. c
  134. c    this AST service routine processes the terminal
  135. c    input.
  136. c
  137.     implicit integer*4 (a-z)
  138.     integer*2 iosb(4),mbxchan,mbxch,ttchan
  139.     character*80 ttbuf
  140.     character*150 mbxbuf
  141.     common ttchan,iosb,ttbuf
  142.     character ttname*11 /'sys$command'/
  143.     external ast2
  144.     include '($iodef)'
  145.     last2 = %loc(ast2)
  146. c    status = sys$assign(ttname, ttchan,,,)
  147. c    if( .not. status ) call lib$stop(%val(status))
  148. c
  149. c    first, read message in mailbox so next write attention
  150. c    AST not delivered until next message written.
  151. c
  152.     status = sys$qiow(,%val(mbxchan),%val(io$_readvblk),,,,
  153.      *        %ref(mbxbuf),%val(len(mbxbuf)),,,,)
  154.     write(6,*) mbxbuf
  155.     if( .not. status ) call lib$stop(%val(status))
  156. c
  157. c    read input from the terminal and write it back.
  158. c
  159. c    read(1,'(q,a)',end=100) length, ttbuf
  160.     status = sys$qio(,%val(ttchan),%val(io$_readvblk),iosb,
  161.      *    %val(last2),mbxchan,%ref(ttbuf),%val(len(ttbuf)),,,,)
  162.      if( .not. status) call lib$signal(%val(status))
  163. c    write(6,'('' qio has setup'')')
  164.     return
  165.     end
  166.     subroutine ast2(mbxchan)
  167.     integer*2 iosb(4),mbxchan,ttchan
  168.     character*80 ttbuf
  169.     logical*1 isr
  170.     common ttchan,iosb,ttbuf
  171.     common /test/ i,isr
  172.     length = iosb(2)
  173.     if( length .eq. 0 ) then
  174.         write(1,4)
  175.     else
  176.         write(1,3) ttbuf 
  177.     3   format(' you typed: ',a<length>)
  178.     4    format(' you typed: <CR>')
  179.     end if
  180.     write(6,'('' i = '',i10,'' isr ='',l4)') i,isr
  181. c
  182. c    re-enable AST
  183. c
  184.     call enable1(mbxchan)
  185.     return
  186. c
  187. c    wake process
  188.   100    call sys$wake(,)
  189.     return
  190.     end
  191.     subroutine isr_timer
  192.     integer*4 sys$wake,status,sys$cancel
  193.     logical*1 isr
  194.     integer*2 ttchan,iosb(4)
  195.     character*80 ttbuf
  196.     common ttchan,iosb,ttbuf
  197.     common /test/i,isr
  198.     status = sys$cancel(%val(ttchan))
  199.     call lib$signal(%val(status))
  200.      write(6,'('' s.r. isr_timer'')')
  201.     isr = .true.
  202.     status = sys$wake(,)
  203.     if( .not. status ) call lib$signal(%val(status))
  204.     return
  205.     end
  206.     subroutine disable1(mbxchan)
  207. c
  208. c
  209.     implicit integer*4 (a-z)
  210.     integer*2    mbxchan
  211.     external ast3
  212.     include '($iodef)'
  213. c
  214.     wrt_ast = io$_setmode 
  215. c
  216. c
  217.     status = sys$qiow(,%val(mbxchan),%val(wrt_ast),,,,ast3,mbxchan,,,,)
  218.     if( .not. status ) call lib$stop(%val(status))
  219.     return
  220.     end
  221.     subroutine ast3(mbxchan)
  222.     integer*2 mbxchan
  223.     write(6,'('' s.r. ast3'')')
  224.     return
  225.     end
  226. c
  227. c
  228. ---------------------- cut here ----------------------
  229.  
  230. I hope it will be helpfully
  231.  
  232. greetinx
  233. Wolfgang
  234.  
  235. ----------------------------------------------------
  236.