      program fix_image
      implicit none
c
      character*80 tmpfil, filnam
      integer ifirst, ilast, i, lfilnm, strlen
      integer*2 rec_size
c
      write (6,10)
 10   format (' Enter template : ',$)
      read (5,'(a)') tmpfil
c
      write (6,20)
 20   format (' Enter start AND end image numbers ',$)
      read (5,*) ifirst, ilast
c
 25   write (6,30)
 30   format (' Enter required record length (2400 or 4000) : ',$)
      read (5,*) rec_size
      if (rec_size.ne.2400.and.rec_size.ne.4000) go to 25
c
      do 100 i=ifirst, ilast, 1
c
         call namfil (tmpfil, i, filnam, lfilnm)
         write (6,110) filnam(1:strlen(filnam))
 110     format (' Resetting attributes for image ',A,' ...')
         call change_attr (filnam, rec_size)
c
 100  continue
c
      end
c
      integer function strlen (string)
      implicit none
      character*(*) string
c
      integer i
      do 10 i = len(string), 1 , -1
         if (string(i:i).ne.' ') go to 20
 10   continue
 20   strlen = i
c
      return
c
      end
c
      subroutine change_attr (filnam, rec_size)
      implicit none
c
      character*(*) filnam
      integer*2 rec_size
c
      include '($atrdef)'
      include '($fabdef)'
      include '($iodef)'
c
      structure /fatdef/
         byte      fat$b_rtype
         byte      fat$b_rattrib
         integer*2 fat$w_rsize
         byte      %fill(12)
         integer*2 fat$w_maxrec
         byte      %fill(14)
      endstructure
c
      record /atrdef/ atr(2)
      record /fabdef/ fab
      record /fatdef/ fat
c
      integer iosb(2)
      integer is, sys$open, sys$qiow
c
c======open the file
c
      fab.fab$b_bid = fab$c_bid
      fab.fab$b_bln = fab$c_bln
      fab.fab$b_fac = fab$m_get .or. fab$m_put
      fab.fab$l_fna = %loc(filnam)
      fab.fab$b_fns = len(filnam)
      fab.fab$l_fop = fab$m_sqo .or. fab$m_ufo
      fab.fab$w_ifi = 0
      fab.fab$b_rtv = 1
      is = sys$open(fab)
      if (.not.is) call lib$signal(%val(is))
c
      atr(1).atr$w_size = atr$s_recattr
      atr(1).atr$w_type = atr$c_recattr
      atr(1).atr$l_addr = %loc(fat)
      atr(2).atr$w_size = 0
c
c======get the required attributes
c
      is = sys$qiow(,%val(fab.fab$l_stv),%val(io$_access),iosb,,,
     &     ,,,,atr,)
      if (is) is = iosb(1)
      if (.not.is) call lib$signal(%val(is))
c
c======change to fixed length records, no carriage control information
c
      fat.fat$b_rtype = fab$c_fix
      fat.fat$b_rattrib = 0
      fat.fat$w_rsize = rec_size
      fat.fat$w_maxrec = rec_size
c
c======and reset them
c
      is = sys$qiow(,%val(fab.fab$l_stv),%val(io$_deaccess),iosb,,,
     &     ,,,,atr,)
      if (is) is = iosb(1)
      if (.not.is) call lib$signal(%val(is))
c
      end
c
c===============MADNES derived code===================
c
      SUBROUTINE NAMFIL(TMPFIL, NUM, FILNAM, LFILNM)
C
C  NAMFIL   NAMe a FILe based on a template file name and an integer.
C  ======
C
C     10-Apr-1990       J. W. Pflugrath         Cold Spring Harbor Laboratory
C        Change call to ERROUT to remove concatentation.
C  14-Jan-1988      J. W. Pflugrath         Cold Spring Harbor Laboratory
C
C  Read Only:
C     TMPFIL    Character    A template file name.  The string contains
C                            the character # to designate a part of the
C                            field which will contain the number specified
C                            in NUM.  Example:  FILE###.###
C     NUM       Integer      An integer number to be formatted and placed
C                            in the # fields of TMPFIL.
C
C  Write Only:
C     FILNAM    Character    The output file name (without #s) generated
C                            by this routine.  The # field will be zeroed
C                            filled on the left and a minus sign will be
C                            changed to _ (underscore).
C     LFILNM    Integer      The number of characters (from the left) used
C                            to construct output FILNAM.  Should equal the
C                            lesser of the total number of characters in TMPFIL
C                            and the number of characters in FILNAM.
C  Subroutines called:
C     ERROUT
C     LEN, MIN, INDEX    (Fortran Intrinsic functions)
C
      CHARACTER*(*)  TMPFIL, FILNAM
      INTEGER        NUM, LFILNM
C
C  Local variables:
C
      CHARACTER*15   CNUM
      CHARACTER*131  STRING
      INTEGER        LTMPFL, LSTRNG, FSTHSH, LCNUM, I, ISTAT
C
      ISTAT = 0
      LTMPFL = LEN(TMPFIL)
      LFILNM = MIN(LEN(FILNAM), LTMPFL)
      FILNAM = TMPFIL
C
C  Put integer NUM into string CNUM.
C
      WRITE (CNUM, 200) ABS(NUM)
200   FORMAT (I15)
      LCNUM = 15
C
C  Find first hash in FILNAM, it will hold sign if NUM is negative and
C  there is room for it.
C
      FSTHSH = INDEX(FILNAM, '#')
      IF (FSTHSH .GT. 0) THEN
         DO 300 I = LFILNM, FSTHSH, -1
            IF (FILNAM(I:I) .EQ. '#') THEN
C
C  Replace with digit from CNUM as long as it available and is non-blank.
C  If it is blank, replace with a 0.
C
               IF (LCNUM .GT. 0) THEN
                  IF (CNUM(LCNUM:LCNUM) .EQ. ' ') THEN
                     FILNAM(I:I) = '0'
                  ELSE
                     FILNAM(I:I) = CNUM(LCNUM:LCNUM)
                  ENDIF
               ELSE
C
C  No more characters available in CNUM, use underscore to replace hash
C
                   FILNAM(I:I) = '_'
               ENDIF
               LCNUM = LCNUM - 1
            ENDIF
300      CONTINUE
C
C  See if positive digits still left in CNUM
C
         IF (LCNUM .GT. 0) THEN
            IF (CNUM(1:LCNUM) .NE. ' ') THEN
               STRING = 'WARNING in NAMFIL, template overflow '//
     &                  'with file number: '
               LSTRNG = MSSLEN(STRING)
               CALL ERROUT(STRING(1:LSTRNG), 0, NUM)
            ENDIF
         ENDIF
C
C  Deal with minus sign if necessary
C
         IF (NUM .LT. 0) THEN
            IF (FILNAM(FSTHSH:FSTHSH) .EQ. '0') THEN
                 FILNAM(FSTHSH:FSTHSH) = '_'
            ELSE
               STRING = 'WARNING in NAMFIL, no room for minus '//
     *                      'sign in '//FILNAM(1:LFILNM)
               LSTRNG = MSSLEN(STRING)
               CALL ERROUT(STRING(1:LSTRNG), 0, 0)
            ENDIF
         ENDIF
      ENDIF
      RETURN
      END
C======================================================================
C
      SUBROUTINE ERROUT(STRING, ISTAT, IREPRT)
C
C======================================================================
C
C     ERROUT   Write error messages to appropriate place(s)
C     ======   Extra feature: It writes out a error message associted
C              with the last FORTRAN error.  This could lead to trouble
C              if this routine is called to signal a non-fortran error
C              after a unreported fortran error has occured.  An extra
C              input field could be added, but would not maintain
C              compatibility with the original version
C======================================================================
      CHARACTER*(*) STRING
      INTEGER       ISTAT, IREPRT
C/PARSE1/
C
C     This common block is found in RDSTRG, GETTOK, GETCOM, GETNUM,
C     GTSTRG, ERROUT, LUNSET, LUNINQ
C
      INTEGER         QMXTOK
      PARAMETER      (QMXTOK = 20)
      COMMON /PARSE1/ ITOK(3, QMXTOK),
     *            IPLUN, OPLUN, OUTLUN, ERRLUN, LOGLUN, IPSTAT,
     *            LPRMPT, LLINE, IPMODE, NUMTOK, NXTTOK,
     *            ERROR, COMMNT, LHLPLB, LHLPCM
      INTEGER     ITOK, IPLUN, OPLUN, OUTLUN, ERRLUN, LOGLUN,
     *            IPSTAT, LPRMPT, LLINE, IPMODE, NUMTOK, NXTTOK,
     *            ERROR, COMMNT, LHLPLB, LHLPCM
C/PARSE1/
C Make sure /PARSE1/ blockdata gets linked:
      EXTERNAL PRS1BD
C
      INTEGER      STATUS
      CHARACTER*80 MSGTXT
      INTEGER      MSGLEN, I
      IF (ISTAT .NE. 0) THEN
         IF (IREPRT .NE. 0) THEN
            IF (LOGLUN .NE. 0) WRITE (LOGLUN, 1000) STRING, ISTAT,
     *                         IREPRT
            WRITE (ERRLUN, 1000) STRING, ISTAT, IREPRT
1000        FORMAT (' ! ***', A, ',  ISTAT=', I5, ',  IREPRT=', I5)
         ELSE
            IF (LOGLUN .NE. 0) WRITE (LOGLUN, 1100) STRING, ISTAT
            WRITE (ERRLUN, 1100) STRING, ISTAT
1100        FORMAT (' ! ***', A, ',  ISTAT=', I5)
         ENDIF
CVAX
         CALL ERRSNS (I,I,I,I, STATUS)
         IF ( STATUS .NE. 1 .AND. STATUS .NE. 0) THEN
            CALL LIB$SYS_GETMSG(STATUS,MSGLEN,MSGTXT,1)
            I = INDEX(MSGTXT(1:MSGLEN),'!')-1
            IF (I .GE. 0 ) MSGLEN = I
            IF (LOGLUN .NE. 0) WRITE (LOGLUN, 1200) MSGTXT(1:MSGLEN)
            WRITE (ERRLUN, 1200) MSGTXT(1:MSGLEN)
1250        FORMAT (' ! ***', A )
         ENDIF
CVAX
      ELSE IF (IREPRT .NE. 0) THEN
         IF (LOGLUN .NE. 0) WRITE (LOGLUN, 1200) STRING, IREPRT
         WRITE (ERRLUN, 1200) STRING, IREPRT
1200     FORMAT (' ! ***', A, I5)
      ELSE
         IF (LOGLUN .NE. 0) WRITE (LOGLUN, 1200) STRING
         WRITE (ERRLUN, 1200) STRING
      ENDIF
      RETURN
      END
C======================================================================
C
      FUNCTION MSSLEN(LINE)
      INTEGER  MSSLEN
C
C---------------------------------------------------------------------
C     Determine the position of the last character in a string LINE
C---------------------------------------------------------------------
      CHARACTER *(*) LINE
      DO 100 MSSLEN = LEN(LINE), 1, -1
         IF (LINE( MSSLEN:MSSLEN ) .GT. ' ') RETURN
100   CONTINUE
      MSSLEN = 0
      RETURN
      END
C
      BLOCKDATA PRS1BD
C/PARSE1/
C
C     This common block is found in RDSTRG, GETTOK, GETCOM, GETNUM,
C     GTSTRG, ERROUT, LUNSET, LUNINQ
C
      INTEGER         QMXTOK
      PARAMETER      (QMXTOK = 20)
      COMMON /PARSE1/ ITOK(3, QMXTOK),
     *            IPLUN, OPLUN, OUTLUN, ERRLUN, LOGLUN, IPSTAT,
     *            LPRMPT, LLINE, IPMODE, NUMTOK, NXTTOK,
     *            ERROR, COMMNT, LHLPLB, LHLPCM
      INTEGER     ITOK, IPLUN, OPLUN, OUTLUN, ERRLUN, LOGLUN,
     *            IPSTAT, LPRMPT, LLINE, IPMODE, NUMTOK, NXTTOK,
     *            ERROR, COMMNT, LHLPLB, LHLPCM
C/PARSE1/
C
C     Initialize the common blocks:
C
      DATA IPLUN /5/, OPLUN /6/, OUTLUN /6/, ERRLUN /6/, LOGLUN /0/,
     *     LPRMPT /0/, LLINE /0/, IPMODE /0/, NUMTOK /0/, NXTTOK /1/,
     *     LHLPLB /0/, LHLPCM /0/
C
      END
