← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to contrib/iue/libsrc/istfhd.for

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
contrib/iue/libsrc/istfhd.for
 
1
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 
2
C.IDENTIFICATION        ISTFHD.FOR
 
3
C.AUTHOR:               J.D.PONZ  ESA-VILSPA        
 
4
C.KEYWORDS              IUE, GO FORMAT, FILE HEADER
 
5
C.PURPOSE
 
6
C  \begin{TeX}
 
7
C  Reads from 2nd record until the end of the IUE GO file header.
 
8
C  The routine performs the following functions (routine names in brackets)
 
9
C  \begin{enumerate}
 
10
C  \item Reads record record (ISTREC)
 
11
C  \item Translates EBCDIC into ASCII (ISTEAS)
 
12
C  \item Displays the header according to the argument DSPFLG (STTPUT)
 
13
C  \item If it is not the last header record go to 1.
 
14
C  \end{enumerate}
 
15
C  \end{TeX}
 
16
C         
 
17
C.LANGUAGE              F77 
 
18
C.COMMENTS
 
19
C  \begin{TeX}
 
20
C    The following extensions are used:
 
21
C  \begin{itemize}
 
22
C   \item IMPLICIT NONE
 
23
C   \item INCLUDE statement
 
24
C   \item long variable names
 
25
C   \item underscore character
 
26
C  \end{itemize}
 
27
C  \end{TeX}
 
28
C.VERSION: 1.0  INITIAL CODING  09 JUL 1990
 
29
C.VERSION:1.1   REMOVE VMS EXTENSIONS 14 APR 1992
 
30
C------------------------------------------------------------------
 
31
      SUBROUTINE ISTFHD(CHANL,BUFF,DSPFLG,STATUS)
 
32
C
 
33
      IMPLICIT NONE
 
34
      INTEGER       CHANL             ! IN: tape channel number
 
35
      CHARACTER*(*) BUFF              ! IN: buffer with the ascii header
 
36
      INTEGER       DSPFLG            ! IN: display flag
 
37
      INTEGER       STATUS            ! OUT: status
 
38
C
 
39
       INTEGER                I, NLEN, LEN, ICOUNT
 
40
       CHARACTER*72           TEXT2, TEXT3, TEXT4
 
41
       CHARACTER*360          CBUFF
 
42
       CHARACTER*1            CC
 
43
       LOGICAL                LAST
 
44
       DATA                   TEXT2
 
45
     ./'.........1.........2.........3.........4.........5.........6....
 
46
     ......7..'/
 
47
       DATA                    TEXT3
 
48
     ./'1234567890123456789012345678901234567890123456789012345678901234
 
49
     .56789012'/
 
50
       DATA                    TEXT4
 
51
     ./'----------------------------------------------------------------
 
52
     .--------'/
 
53
C
 
54
      NLEN   = 360
 
55
      STATUS = 0
 
56
      IF (DSPFLG.GE.1) THEN
 
57
        CALL STTPUT(TEXT2,STATUS)
 
58
        CALL STTPUT(TEXT3,STATUS)
 
59
        CALL STTPUT(TEXT4,STATUS)
 
60
      ENDIF
 
61
C
 
62
C ... writes the first header lines
 
63
C
 
64
      LAST = .FALSE.
 
65
      DO 10 I = 72, NLEN, 72
 
66
           IF (DSPFLG.GE.1) CALL STTPUT(BUFF(I-71:I),STATUS)
 
67
           IF (BUFF(I:I).EQ.'L') LAST = .TRUE.
 
68
 10   CONTINUE
 
69
      IF (LAST) THEN
 
70
        IF (DSPFLG.GE.1)  CALL STTPUT(TEXT4,STATUS)
 
71
        RETURN
 
72
      ENDIF
 
73
      ICOUNT = 6
 
74
C
 
75
C ... skip records
 
76
C
 
77
 15   CALL ISTREC(CHANL,CBUFF,NLEN,LEN,STATUS)
 
78
      IF (NLEN.NE.LEN .OR. STATUS.NE.0) RETURN
 
79
      DO 20  I = 72, NLEN, 72
 
80
         IF (DSPFLG.GE.2 .AND. .NOT.LAST .AND.
 
81
     .       (ICOUNT.LT.38 .OR. ICOUNT.GT.100))
 
82
     .                 CALL STTPUT(CBUFF(I-71:I),STATUS)
 
83
         ICOUNT = ICOUNT + 1
 
84
         CC = CBUFF(I:I)
 
85
         IF (CC.EQ.'L') LAST = .TRUE.
 
86
 20   CONTINUE
 
87
      IF (.NOT.LAST) GOTO 15
 
88
      RETURN
 
89
      END