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