c ********************************************************************** c c LEGACY_FILE_READER :: LFR :: Fortran Version c c Copyright (c) 2001, Salford Systems c All Rights Reserved Worldwide c This program is provided AS-IS with no c warranty whatsoever. c c LFR: a program to illustrate how to read legacy c SYSTAT-format datasets (e.g., .SYS, .SYD) in c Fortran. The data will be written to the console c in comma-separated form. c c The C version of this is somewhat more complex, due to c the fact that files created with Fortran typically c contain beginning- and end-of-record integer markers, c which are accounted for explicitly in the C program. c c Questions? Suspected bugs? Please email c plc@salford-systems.com and put "LFR" in the c subject line, and attached (MIME encoding is the c norm) a copy of the legacy dataset that is causing c a problem. c c v1.0 August 2001. c c ********************************************************************** program legacy_file_reader implicit none real*8 dmis real*4 rmis integer ml ! max N chars in a character variable data point integer mv ! max N variables in a legacy dataset integer kver,krel,kmod ! legacy version numbers, leave alone parameter (ml=12,mv=8192) parameter (kver=30,krel=0,kmod=0) parameter (rmis=-1.0e36,dmis=-1.0d36) real*8 dta real*4 sta character*1 rec,khr,label,letter character*14 datavalue character*256 filename integer inunit,nchrvar,nnumvar,i,j,im,jm,nd,nk integer vartype,rec_len #ifdef WIN32 integer*2 version,release,mod integer*2 nv,mtype,ntype #else integer version,release,mod integer nv,mtype,ntype #endif dimension dta(mv),sta(mv),khr(ml,mv) dimension rec((ml+3)*mv),label(ml) dimension vartype(mv) inunit=10 nchrvar=0 ! N character variables on dataset nnumvar=0 ! N numeric variables on dataset write(*,*,err=999) ' Please input the dataset filename' read(*,"(a256)",err=999) filename open(inunit,file=filename,form='unformatted',status='old', . err=999) c read first three integers in header. c these will be integer*2 on Intel, integer on other platforms. read(inunit,err=999,end=999) version,release,mod if (mod.gt.kmod) then nv=version mtype=release ntype=mod go to 5 end if if (version+release.gt.kver+krel) go to 999 c skip over comment records, which are terminated with a c record of 72 dollar signs ('$'). 1 read(inunit,end=999,err=999) letter if (letter.ne.'$') goto 1 c read second three integers in header. c these will be integer*2 on Intel, integer on other platforms. read(inunit,err=999,end=999) nv,mtype,ntype if (nv.gt.mv) goto 999 ! too many variables on the dataset c read the variable names c c legal names are composed of letters, numbers, parens c enclosing numbers (i.e., subscripts), underscores and c dollar sign. The dollar sign, if it appears, can only c appear at the end of the variable name and indicates c that the variable is a character variable. The variable c name may only begin with a letter. Subscripts, e.g., c VARIABLE(35), must be between 1 and 99 to be supported by c Salford Systems programs although the file format allows c subscripts greater than 99. Underscores may appear amid c or at the end of a variable name. rec_len=0 5 do 10 j=1,nv read(inunit,end=999,err=999) (label(i),i=1,ml) vartype(j)=0 ! numeric variable do 7 i=1,ml if (label(i).eq.'$'.or.label(i).eq.'_'.or. . label(i).eq.'('.or.label(i).eq.')'.or. . (label(i).ge.'A'.and.label(i).le.'Z').or. . (label(i).ge.'a'.and.label(i).le.'z').or. . (label(i).ge.'0'.and.label(i).le.'9')) then rec_len=rec_len+1 rec(rec_len)=label(i) end if if (label(i).eq.'$') vartype(j)=1 ! character variable 7 continue if (j.lt.nv) then rec_len=rec_len+1 rec(rec_len)=',' end if if (vartype(j).eq.0) then nnumvar=nnumvar+1 else nchrvar=nchrvar+1 end if 10 continue c echo the variable names to console write(*,9000,err=999) (rec(i),i=1,rec_len) 9000 format(122880a1) c loop over records in the dataset 100 continue c dataset has numeric data, and perhaps char data too if (nnumvar.gt.0) then if (ntype.eq.1) then ! single precision dataset if (nchrvar.gt.0) then read(inunit,end=200,err=999) (sta(j),j=1,nnumvar), * ((khr(i,j),i=1,ml),j=1,nchrvar) else read(inunit,end=200,err=999) (sta(j),j=1,nnumvar) end if do 105 i=1,nnumvar if (sta(i).ne.rmis) then dta(i)=sta(i) else dta(i)=dmis end if 105 continue else ! double precision dataset if (nchrvar.gt.0) then read(inunit,end=200,err=999) (dta(j),j=1,nnumvar), * ((khr(i,j),i=1,ml),j=1,nchrvar) else read(inunit,end=200,err=999) (dta(j),j=1,nnumvar) end if end if if (nchrvar.gt.0) then ! unpack so that numeric and nd=nnumvar+1 ! character values are positioned nk=nchrvar+1 ! according to their variable name do 120 j=1,nv ! locations in the header. jm=nv-j+1 if (vartype(jm).eq.0) then nd=nd-1 dta(jm)=dta(nd) else nk=nk-1 do 110 i=1,ml khr(i,jm)=khr(i,nk) 110 continue end if 120 continue end if c dataset contains only character data else read(inunit,end=200,err=999) ((khr(i,j),i=1,ml),j=1,nchrvar) end if c echo data to console rec_len=0 do 150 i=1,nv if (vartype(i).eq.0) then ! numeric if (dta(i).eq.dmis) then rec_len=rec_len+1 rec(rec_len)='.' else write(datavalue,"(g14.7)",err=999) dta(i) do 130 j=1,14 rec_len=rec_len+1 rec(rec_len)=datavalue(j:j) 130 continue end if else rec_len=rec_len+1 rec(rec_len)='"' do 140 j=1,ml rec_len=rec_len+1 rec(rec_len)=khr(j,i) 140 continue rec_len=rec_len+1 rec(rec_len)='"' end if if (i.lt.nv) then rec_len=rec_len+1 rec(rec_len)=',' end if 150 continue write(*,9000,err=999) (rec(i),i=1,rec_len) goto 100 ! get another data record 200 continue close(inunit,status='keep') goto 999 999 continue stop ' ' end