subroutine rsaf(fname,ndatma,iopt,datath,npts,sfre,ier) c c Read Sesame Ascii Format data c c a.tento 09/02 v. 2.0 c a.tento 06/03 v. 2.1 -> GAIN parameter added (not mandatory) c c ARGUMENTS: c -- input -- c fname : input file name c ndatma : row dimension of matrix "datath" as specified in the c dimension statement of the calling program c iopt : option = 0 read header and data time histories c = 1 read only header c -- output -- c datath(ndatma,3) : time histories for 3 channels, must be dimensioned c in the calling program c npts : number of points of time histories c sfre : sampling frequency in Hz c ier : error code = 0 : no error c = 2 : or 3 problem in getting an unused fortran file unit c = 4 : problem in opening the file (e.g. permission denied or c the file does not already exist) c = 7 : the mandatory parameters have NOT been completely set c = 8 : number of time history points greater than "ndatma" c = 9 : error in reading time histories data c = 50 : the opened file is NOT a current version SAF file c > 1000 : problem header reading line : ier - 1000 c c implicit none c c....... ARGUMENTS character fname*(*) integer ndatma, iopt, npts, ier real datath, sfre dimension datath(ndatma,3) c c....... IDENTIFIERS SAF v. 1 integer iver, ibeg parameter ( iver = 35, ibeg = 24) character version*(iver), begdat*(ibeg), comment*1, sep*1 parameter ( version = 'SESAME ASCII data format (saf) v. 1' ) parameter ( begdat = '####--------------------' ) parameter ( comment = '#' ) parameter ( sep = '=' ) c c....... /SAFHDR8/ integer length parameter ( length = 100 ) integer year, month, day, hour, minute, isec, msec, ndat real second, samp_freq, north_rot, gain character*(length) sta_code, ch0_id, ch1_id, ch2_id, units common /safhdr8/ year, month, day, hour, minute, isec, # msec, ndat, second, samp_freq, north_rot, gain, # sta_code, ch0_id, ch1_id, ch2_id, units c c....... UNDEFINED integer iundef real rundef character*8 cundef parameter ( iundef = -12345) parameter ( rundef = -12345.0e+00 ) parameter ( cundef = '-12345') c c c....... LOCAL VARIABLES integer mheader, mmand parameter ( mheader = 10, mmand = 8 ) character*(length) header(mheader), row, argout(2), # headcod(mheader) c integer large parameter (large=2147483600) c logical free integer i, nunit, j, ind, k integer numax, numin parameter ( numax=50, numin=31 ) c data headcod / 'STA_CODE','SAMP_FREQ','NDAT','START_TIME', # 'UNITS', 'CH0_ID', 'CH1_ID', 'CH2_ID', # 'NORTH_ROT', 'GAIN' / c c ....... first executable statement c ier = 0 c c ....... header initialization c do 1 i = 1, mheader header(i) = cundef 1 continue year = iundef month = iundef day = iundef hour = iundef minute = iundef isec = iundef msec = iundef ndat = iundef second = rundef samp_freq = rundef north_rot = rundef sta_code = cundef ch0_id = cundef ch1_id = cundef ch2_id = cundef units = cundef gain = rundef sfre = samp_freq npts = ndat c c ....... get a currently unused fortran file unit c do 4 i = numin, numax nunit = i inquire(unit=nunit,err=302,opened=free) if (.not.free) goto 5 4 continue c goto 303 c 5 continue c c ....... open file and read first line c open(nunit,file=fname,form='formatted',access='sequential', # status='old', err=304) c k = 1 read(nunit,100,err=305)row if ( row(1:iver) .ne. version ) goto 350 c do 6 i = 1, large k = i + 1 read(nunit,100,err=305)row if ( row(1:ibeg) .eq. begdat ) goto 7 if ( row(1:1) .eq. comment ) goto 6 if ( row .eq. ' ' ) goto 6 call spltct8(row,sep,argout,length) call toups8(argout(1)) do 8 j = 1, mheader ind = j if ( headcod(j) .eq. argout(1) ) goto 9 8 continue goto 306 9 continue c header(ind)=argout(2) c 6 continue c 7 continue c do 2 i = 1, mmand if ( header(i) .eq. cundef ) goto 307 2 continue c sta_code = header(1) read(header(2),*)samp_freq sfre = samp_freq read(header(3),*)ndat npts = ndat read(header(4),*) year, month, day, hour, minute, second isec = int(second) msec = int((second - float(isec))*1000.0 + 0.5) units = header(5) ch0_id = header(6) ch1_id = header(7) ch2_id = header(8) if ( header(9) .ne. cundef ) read(header(9),*)north_rot if ( header(10) .ne. cundef ) read(header(10),*)gain c if ( iopt .eq. 1 ) goto 99 c if ( npts .gt. ndatma ) goto 308 do 10 i = 1, npts read(nunit,*,err=309)(datath(i,j),j=1,3) 10 continue c if ( gain .ne. rundef ) then do 18 j = 1, 3 do 17 i = 1, npts datath(i,j) = datath(i,j) / gain 17 continue 18 continue endif c 99 continue close(nunit) return c c ........ inquire error 302 ier = 2 return c c ........ no units free 303 ier = 3 return c c ........ cannot open 304 ier = 4 return c c---------------------------------------------------------------------- c ........ cannot read at line : ier - 1000 305 ier = 1000 + k close(nunit) return c c ........ incorrect key word found at line : ier - 1000 306 ier = 1000 + k close(nunit) return c c ........ problem in reading parameter values at line : ier - 1000 311 ier = 1000 + k close(nunit) return c---------------------------------------------------------------------- c c ........ not all the mandatory parameters are set 307 ier = 7 close(nunit) return c c ........ npts > ndatma 308 ier = 8 close(nunit) return c c ........ error in reading time histories data 309 ier = 9 close(nunit) return c c ........ the opened file is NOT a current version SAF file 350 ier = 50 close(nunit) return c c 100 format(a100) c c c end subroutine toups8(string) c c convert "string" to upper case c c a.tento 05/02 v.1.0 c c ARGUMENTS c string : c -- input -- c character variable to be converted in upper case c -- output -- c upper case version of input string c c c....... ARGUMENTS character string*(*) c c....... LOCAL VARIABLES integer i, j, k, m character*1 upper(26), lower(26) data upper / 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'I', 'J', # 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', # 'U', 'V', 'W', 'X', 'Y', 'Z' / data lower / 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', # 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', # 'u', 'v', 'w', 'x', 'y', 'z' / c c ....... first executable statement c m = len(string) c do 1 i = 1, m do 2 j = 1, 26 k = j if ( string(i:i) .eq. lower(j) ) goto 3 2 continue goto 1 3 string(i:i) = upper(k) 1 continue c return c end subroutine spltct8(row,sep,argout,length) c c Split a character string ("row*(length)") in two parts c (i.e. keyword and its argument) and put them in "argout*(length)". c Separator is specified by "sep" (character*1). c Initial blank are removed. c c a.tento 5/02 v.1.0 c c ARGUMENTS: c -- input -- c row : character*length string to be split [c] c sep : character*1 separator [c] c -- output -- c argout : character*length vector(2) of parts found in "row" [c] c length : length of character string c c c....... ARGUMENTS integer length c_g77__ character row*(length), sep*1, argout(2)*(length) character row*(*), sep*1, argout(2)*(*) c c....... LOCAL VARIABLES character cblank*1 parameter (cblank = ' ' ) integer k, j, i c c do 10 i = 1, length argout(1)(i:i) = cblank argout(2)(i:i) = cblank 10 continue c k = 0 j = 0 do 1 i = 1, length k = i if( row(i:i) .eq. cblank ) goto 1 if( row(i:i) .eq. sep ) goto 2 j = j + 1 argout(1)(j:j) = row(i:i) 1 continue return c 2 continue do 3 i = k+1, length j = i if( row(i:i) .eq. cblank ) goto 3 goto 4 3 continue c 4 continue argout(2) = row(j:length) c return c end