home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / MISC / MATH / SPECTR20.ZIP / MAKDAT.FOR < prev    next >
Encoding:
Text File  |  1992-04-28  |  8.3 KB  |  278 lines
  1. *    MAKDAT.FOR
  2.  
  3. *    Create a binary data file which
  4. *    can be read by the spectrum routine.
  5.  
  6. *    David E. Hess
  7. *    Fluid Flow Group - Process Measurements Division
  8. *    Chemical Science and Technology Laboratory
  9. *    National Institute of Standards and Technology
  10. *    April 15, 1992
  11.  
  12. *    This routine reads an ASCII input data file and rewrites
  13. *    the data into a binary data file which can be processed by the
  14. *    SPECTRUM calculation program. The routine first prompts the
  15. *    user for information necessary to create the file header and
  16. *    then the rewriting procedure begins. Extensive error checking
  17. *    is included in an attempt to make the transformation process as
  18. *    painless as possible. Refer to the section in the user's manual
  19. *    for further details.
  20.  
  21. *            File Extensions
  22. *            ---------------
  23. *    .ASC - ASCII input data file (no header, just numbers)
  24. *    .DAT - Binary output file (with file header)
  25.  
  26. *            Header Information
  27. *            ------------------
  28. *    ICHANS    : # of channels of data.
  29. *    IDELTMS    : sampling interval in microseconds.
  30. *    IRSIZE    : # of bytes in each record.
  31. *    N    : # of points per record per channel.
  32. *    NUMREC    : # of records in data file.
  33. *    GAIN    : array of gain values for each channel
  34.  
  35.     IMPLICIT    REAL*4 (A-H,O-Z), INTEGER*2 (I-N)
  36.     PARAMETER    (NUMI=2,NUMO=3,NMAX=16384)
  37.     INTEGER*2    GAIN(0:7)
  38.     INTEGER*2    NDATA[ALLOCATABLE,HUGE](:)
  39.     INTEGER*4    IRSIZE,IDELTMS
  40.     REAL*4        RDATA[ALLOCATABLE,HUGE](:)
  41.     LOGICAL*1    INTGER,FLOTNG,ONECHAN,TWOCHAN
  42.     CHARACTER    INSFX *4 /'.ASC'/, OUTSFX *4 /'.DAT'/
  43.     CHARACTER*1    INP,FIRST
  44.     CHARACTER*4    INNAM
  45.     CHARACTER*8    INFIL,OUTFIL
  46.  
  47. *    Initialize gain array.
  48.  
  49.     GAIN=0
  50.  
  51. *    Integer or floating point data ?
  52.  
  53. 10    WRITE (*,'(/1X,A,A\)') '(I)nteger (2-byte) or ',
  54.      +                      '(F)loating-point (4-byte) data : '
  55.     READ (*,'(A)') INP
  56.     IF (INP .EQ. 'i') INP = 'I'
  57.     IF (INP .EQ. 'f') INP = 'F'
  58.     INTGER=(INP .EQ. 'I')
  59.     FLOTNG=(INP .EQ. 'F')
  60.     IF (.NOT. INTGER .AND. .NOT. FLOTNG) GO TO 10
  61.  
  62. *    Get # of channels.
  63.  
  64. 20    WRITE (*,'(/1X,A\)') 'Enter # of channels (1 or 2) : '
  65.     READ (*,*) ICHANS
  66.     ONECHAN=(ICHANS .EQ. 1)
  67.     TWOCHAN=(ICHANS .EQ. 2)
  68.     IF (.NOT. ONECHAN .AND. .NOT. TWOCHAN) GO TO 20
  69.  
  70. *    Get # of points per record per channel.
  71.  
  72.     WRITE (*,'(/1X,A,I5,A/1X,A,A,I5,A)')
  73.      +    'One channel  : Total # points per record <= ',
  74.      +    NMAX,'.','Two channels : Total # points per record',
  75.      +    ' per channel <= ',NMAX/2,'.'
  76.  
  77. 30    IF (ONECHAN) THEN
  78.       WRITE (*,'(/1X,A,A\)') 'Enter # of points per',
  79.      +                          ' record (power of two) : '
  80.       READ (*,*) N
  81.     ELSE
  82.       WRITE (*,'(/1X,A,A/1X,A\)') 'Enter # of points per',
  83.      +              ' record for each channel (power of two).',
  84.      +    'Total # of points per record is double this number : '
  85.       READ (*,*) N
  86.     ENDIF    
  87.  
  88. *    N less than or equal to NMAX error checking.
  89.  
  90.     IF (ONECHAN) NTST=NMAX
  91.     IF (TWOCHAN) NTST=NMAX/2
  92.     IF (N .GT. NMAX) THEN
  93.       WRITE (*,'(/1X,A,A,I5,A)') '# of points per record',
  94.      +         ' per channel <= ',NTST,' dummy!'
  95.       GO TO 30
  96.     ENDIF
  97.  
  98. *    Power of two error checking.
  99.  
  100.     FN=FLOAT(N)
  101.     ITST=NINT(ALOG10(FN)/ALOG10(2.0))
  102.     ITST2=INT(2**ITST)-N
  103.  
  104.     IF (ITST2 .NE. 0) THEN
  105.       WRITE (*,'(/1X,A,I5,A/1X,A)') 'You have entered ',
  106.      +           N,' data points.','# data points must be a power of 2.'
  107.       GO TO 30
  108.     ENDIF
  109.  
  110.     IF (INTGER) IRSIZE=ICHANS*N*2
  111.     IF (FLOTNG) IRSIZE=ICHANS*N*4
  112.  
  113. *    Allocate space for NDATA and RDATA arrays.
  114.  
  115.     IF (ONECHAN .AND. INTGER) ALLOCATE (NDATA(N), STAT=IERR)
  116.     IF (ONECHAN .AND. FLOTNG) ALLOCATE (RDATA(N), STAT=IERR)
  117.     IF (TWOCHAN .AND. INTGER) ALLOCATE (NDATA(2*N), STAT=IERR)
  118.     IF (TWOCHAN .AND. FLOTNG) ALLOCATE (RDATA(2*N), STAT=IERR)
  119.     IF (IERR .NE. 0)
  120.      +          STOP 'Not enough storage for data.  Aborting ...'
  121.  
  122. *    Get # of records in data file.
  123.  
  124.     WRITE (*,'(/1X,A/1X,A)')
  125.      +    'One channel  : May be EVEN or ODD # of records.',
  126.      +    'Two channels : May be EVEN or ODD # of records.'
  127.  
  128.     WRITE (*,'(/1X,A\)') 'Enter # of records in the data file : '
  129.     READ (*,*) NUMREC
  130.  
  131. *    Get the sampling interval.
  132.  
  133.     WRITE (*,'(/1X,A/1X,A/1X,A/1X,A)')
  134.      +'One chan  : Delta t is spacing between data points.',
  135.      +'Two chans : Delta t is spacing between data pts - SAME channel.',
  136.      +'            Delta t divided by 2 is spacing between data pts',
  137.      +'            - different channels.'
  138.  
  139.     WRITE (*,'(/1X,A\)') 'Enter sampling interval delta t (secs) : '
  140.     READ (*,*) DELT
  141.     IDELTMS=NINT(DELT*1.0E+06)
  142.     WRITE (*,'( )')
  143.  
  144. *    Set the gain for each channel.
  145.  
  146.     WRITE (*,'(14X,A,5X,A)') ' Voltage Range ','Gain'
  147.     WRITE (*,'(14X,A,5X,A)') ' ------------- ','----'
  148.     WRITE (*,'(14X,A,5X,A)') '-10.00 to 10.00','  0 '
  149.     WRITE (*,'(14X,A,5X,A)') '- 5.00 to  5.00','  1 '
  150.     WRITE (*,'(14X,A,5X,A)') '- 2.50 to  2.50','  2 '
  151.     WRITE (*,'(14X,A,5X,A)') '- 1.25 to  1.25','  3 '
  152.     WRITE (*,'( )')
  153.  
  154.     DO I=0,ICHANS-1
  155.       WRITE (*,'(1X,A,I1,A\)') 'Enter gain for channel ',I,' : '
  156.       READ (*,*) GAIN(I)
  157.     ENDDO
  158.  
  159. *    Get input file name.
  160.  
  161. 40    WRITE (*,'(/1X,A\)') 'Enter ASCII input file name (4 chars) : '
  162.     READ (*,'(A)') INNAM
  163.  
  164. *    Convert to uppercase and check first character alphabetic.
  165.  
  166.     DO J=4,1,-1
  167.       FIRST=INNAM(J:J)
  168.       IF (ICHAR(FIRST) .GE. 97 .AND. ICHAR(FIRST) .LE. 122) THEN
  169.         IHOLD=ICHAR(FIRST)-32
  170.         FIRST=CHAR(IHOLD)
  171.         INNAM(J:J)=FIRST
  172.       ENDIF
  173.     ENDDO
  174.     IF (ICHAR(FIRST) .LT. 65 .OR. ICHAR(FIRST) .GT. 90) THEN
  175.       WRITE (*,'(/1X,A,A,A/1X,A,A,A/1X,A)') 
  176.      +      'Filename ',INNAM,' began with',
  177.      +      'the nonalphabetic character ',FIRST,'.',
  178.      +      'Re-enter the filename correctly.'
  179.       GO TO 40
  180.     ENDIF
  181.  
  182.     INFIL=INNAM // INSFX
  183.     OUTFIL=INNAM // OUTSFX
  184.  
  185. *    Put message on screen.
  186.  
  187.     WRITE (*,'(/////////////////////16X,
  188.      +      ''D A T A   F I L E   C R E A T I O N   U T I L I T Y'')')
  189.     WRITE (*,'(/25X,''Creating '',A,'' now.'')') OUTFIL
  190.  
  191. *    Open input ASCII file.
  192.  
  193.     OPEN (NUMI,FILE=INFIL,STATUS='OLD',ERR=100)
  194.  
  195. *    Open output data file and write header.
  196.  
  197.     OPEN (NUMO,FILE=OUTFIL,STATUS='UNKNOWN',ACCESS='SEQUENTIAL',
  198.      +        FORM='BINARY',ERR=110)
  199.     WRITE (NUMO) ICHANS,IRSIZE,NUMREC,IDELTMS
  200.     WRITE (NUMO) (GAIN(I),I=0,7)
  201.  
  202. *    Display header information.
  203.  
  204.     WRITE (*,'(/25X,A,I1)')   '# channels = ',ICHANS
  205.     WRITE (*,'(25X,A,I5,A)')  'record size = ',IRSIZE,' bytes'
  206.     WRITE (*,'(25X,A,I5)')    '# of records = ',NUMREC
  207.     WRITE (*,'(25X,A,I5,A/)') 'delta t = ',IDELTMS,' microseconds'
  208.  
  209.     DO J=1,NUMREC
  210.  
  211. *      Display record count.
  212.  
  213.       IF (J .EQ. 1) THEN
  214.         WRITE (*,50) J
  215. 50        FORMAT (25X,'Record ',I4.4)
  216.       ELSE
  217.         WRITE (*,60) J
  218. 60        FORMAT ('+',24X,'Record ',I4.4)
  219.       ENDIF
  220.  
  221.       IF (INTGER) THEN
  222.         IF (ONECHAN) THEN
  223.           READ (NUMI,*,ERR=120,END=140) (NDATA(I), I=1,N)
  224.           WRITE (NUMO, ERR=130)         (NDATA(I), I=1,N)
  225.         ELSE
  226.           READ (NUMI,*,ERR=120,END=140) (NDATA(I), I=1,2*N)
  227.           WRITE (NUMO, ERR=130)         (NDATA(I), I=1,2*N)
  228.         ENDIF
  229.       ELSE IF (FLOTNG) THEN
  230.         IF (ONECHAN) THEN
  231.           READ (NUMI,*,ERR=120,END=140) (RDATA(I), I=1,N)
  232.           WRITE (NUMO, ERR=130)         (RDATA(I), I=1,N)
  233.         ELSE
  234.           READ (NUMI,*,ERR=120,END=140) (RDATA(I), I=1,2*N)
  235.           WRITE (NUMO, ERR=130)         (RDATA(I), I=1,2*N)
  236.         ENDIF
  237.       ENDIF
  238.     ENDDO
  239.  
  240.     CLOSE (NUMI,STATUS='KEEP')
  241.     CLOSE (NUMO,STATUS='KEEP')
  242.  
  243.     WRITE (*,'( )')
  244.     STOP '                        Program terminated successfully.'
  245.  
  246. *    Problem opening input ASCII file.
  247.  
  248. 100    WRITE (*,'(/25X,A/)') 'Problem opening input ASCII file.'
  249.     STOP '                       Program terminated unsuccessfully.'
  250.  
  251. *    Problem opening output data file.
  252.  
  253. 110    WRITE (*,'(/25X,A/)') 'Problem opening output data file.'
  254.     STOP '                       Program terminated unsuccessfully.'
  255.  
  256. *    Problem reading input ASCII file.
  257.  
  258. 120    WRITE (*,'(/25X,A/)') 'Problem reading input ASCII file.'
  259.     CLOSE (NUMI,STATUS='KEEP')
  260.     CLOSE (NUMO,STATUS='KEEP')
  261.     STOP '                       Program terminated unsuccessfully.'
  262.  
  263. *    Problem writing output data file.
  264.  
  265. 130    WRITE (*,'(/25X,A/)') 'Problem writing output data file.'
  266.     CLOSE (NUMI,STATUS='KEEP')
  267.     CLOSE (NUMO,STATUS='KEEP')
  268.     STOP '                       Program terminated unsuccessfully.'
  269.  
  270. *    Problem : reached end of file marker reading input ASCII file.
  271.  
  272. 140    WRITE (*,'(/25X,A/)') 'Problem : reached end of file marker',
  273.      +                     ' reading input ASCII file.'
  274.     CLOSE (NUMI,STATUS='KEEP')
  275.     CLOSE (NUMO,STATUS='KEEP')
  276.     STOP '                       Program terminated unsuccessfully.'
  277.     END
  278.