! ------------------------------------------------------------------------------
! PP&L VAX Computer Systems <> IBM / DEC Data Format Conversion
! -------------------------------------------------------------
!
! This program converts the contents of an IBM internally formatted file
! into a DEC-compatible file of the same structure
!
! Supported file types:
!
!	ORGANIZATION = SEQUENTIAL
!	FORM         = UNFORMATTED
!	RECORDTYPE   = FIXED
!
! The maximum allowable record size is 9999 bytes
!
! The program is driven off a control file, which describes the input and
! output files
!
! Control file structures (created via a text editor):
!
!	1. The first record of the file contains the specification (name) of
!	   the input file
!
!	2. The second record contains a similar specification for the output
!	   file
!
!	3. Subsequent entries in the control file hold pairs of lines:
!
!		a. The first line of the pair indicates the number of records
!		   of the input file to which the format description in 3b.
!		   is to be applied. If there is no limit, specify -1
!
!		b. The second line of the pair is a format descriptor to be
!		   applied to the input file, for the number of records listed
!		   in 3a. Valid format items are (n is a numeric repeat factor
!		   which is associated with the format item - if omitted, one
!		   is assumed):
!
!			Xn - skip character (do not process the byte)
!			An - character
!			Fn - single-precision floating point
!			Ln - integer longword
!
!		   Each format item is separated by one or more spaces or tabs
!
!
! M. Latshaw <> 07/03/86
! ------------------------------------------------------------------------------


!			-------------------
	PROGRAM		I B M _ T O _ D E C
!			-------------------


	IMPLICIT NONE


	INTEGER*4 NTBLEN			! True string length function


	INTEGER*4   TBL_SIZ
	PARAMETER ( TBL_SIZ = 150 )


	CHARACTER*64 CTL_FILE			! Name of control file
	CHARACTER*64 DEC_FILE			! Name of output file
	CHARACTER*64 IBM_FILE			! Name of input file
	CHARACTER*9  REC_TYPE			! File recordtype

	CHARACTER*9999 DEC_BUF			! Output file buffer
	CHARACTER*1    FMT_ITEM			! Current format item
	CHARACTER*1    FMT_ITM(TBL_SIZ)		! Format item list
	CHARACTER*9999 IBM_BUF			! Input file buffer

	INTEGER*4 BUF_LN			! Length of current record
	INTEGER*4 CTL_FILE_LN			! Length of control file name
	INTEGER*4 CTL_LUN			! Control file logical unit #
	INTEGER*4 DEC_FILE_LN			! Length of output file name
	INTEGER*4 DEC_LUN			! DEC (output) file LUN
	INTEGER*4 FMT_CNT			! Format record item count
	INTEGER*4 FMT_LEN			! Estimated I/O record size
	INTEGER*4 FMT_RPT(TBL_SIZ)		! Format item repeat count table
	INTEGER*4 I				! General index
	INTEGER*4 IBM_FILE_LN			! Length of input file name
	INTEGER*4 IBM_LUN			! IBM (input) file LUN
	INTEGER*4 ISTAT				! File I/O status code
	INTEGER*4 NRECS				! Loop control counter
	INTEGER*4 REC_CNT			! Accumulative record count
	INTEGER*4 REC_LEN			! File record length (longwords)


	DATA CTL_FILE / ' ' /
	DATA NRECS    / 0 /
	DATA REC_CNT  / 0 /


! ----------------------------------
! Fetch the name of the control file
! ----------------------------------

	TYPE *,'Enter the name of the control file (64 characters maximum)'
	ACCEPT '(A)',CTL_FILE

	CTL_FILE_LN = NTBLEN (CTL_FILE)


! ---------------------
! Open the control file
! ---------------------

	CALL GETALUN (CTL_LUN)			! Allocate a LUN

	OPEN (UNIT=CTL_LUN,
	1     FILE=CTL_FILE(1:CTL_FILE_LN),
	1     STATUS='OLD',
	1     READONLY,
	1     SHARED,
	1     IOSTAT=ISTAT)

	IF (ISTAT .NE. 0) THEN

	    TYPE *,'Unable to open file '//CTL_FILE(1:CTL_FILE_LN)
	    CALL EXIT
	    END IF


! -------------------------------
! Read the name of the input file
! -------------------------------

	READ (UNIT=CTL_LUN, FMT='(Q,A)', IOSTAT=ISTAT) IBM_FILE_LN,
	1                                              IBM_FILE(1:IBM_FILE_LN)

	IF (ISTAT .NE. 0) THEN

	    TYPE *,'Unable to read the input file specification'
	    CLOSE (UNIT=CTL_LUN)
	    CALL EXIT
	    END IF


! --------------------------------
! Read the name of the output file
! --------------------------------

	READ (UNIT=CTL_LUN, FMT='(Q,A)', IOSTAT=ISTAT) DEC_FILE_LN,
	1                                              DEC_FILE(1:DEC_FILE_LN)

	IF (ISTAT .NE. 0) THEN

	    TYPE *,'Unable to read the output file specification'
	    CLOSE (UNIT=CTL_LUN)
	    CALL EXIT
	    END IF


! ---------------------------------------------------------------------
! Open the input file. The structure of this file will help to describe
! the output file.
! ---------------------------------------------------------------------

	CALL GETALUN (IBM_LUN)

	OPEN (UNIT=IBM_LUN,
	1     FILE=IBM_FILE(1:IBM_FILE_LN),
	1     STATUS='OLD',
	1     READONLY,
	1     SHARED,
	1     ORGANIZATION='SEQUENTIAL',
	1     ACCESS='SEQUENTIAL',
	1     FORM='UNFORMATTED',
	1     RECORDTYPE='FIXED',
	1     IOSTAT=ISTAT)

	IF (ISTAT .NE. 0) THEN

	    TYPE *,'Unable to open input file '//IBM_FILE(1:IBM_FILE_LN)
	    CLOSE (UNIT=CTL_LUN)
	    CALL EXIT
	    END IF


! ---------------------------------
! Open the output file, accordingly
! ---------------------------------

	INQUIRE (UNIT=IBM_LUN, RECORDTYPE=REC_TYPE)

	IF (REC_TYPE .EQ. 'FIXED') THEN

	    INQUIRE (UNIT=IBM_LUN, RECL=REC_LEN)	! Get record length

	    CALL GETALUN (DEC_LUN)

	    OPEN (UNIT=DEC_LUN,
	1         FILE=DEC_FILE(1:DEC_FILE_LN),
	1         STATUS='NEW',
	1         RECORDTYPE='FIXED',
	1         RECL=REC_LEN,
	1         FORM='UNFORMATTED',
	1         CARRIAGECONTROL='NONE',
	1         ORGANIZATION='SEQUENTIAL',
	1         ACCESS='SEQUENTIAL',
	1         IOSTAT=ISTAT)

	ELSE

	    TYPE *,'Input file has unsupported file type '//REC_TYPE

	    CLOSE (UNIT=CTL_LUN)
	    CLOSE (UNIT=IBM_LUN)

	    CALL EXIT
	    END IF

	IF (ISTAT .NE. 0) THEN

	    TYPE *,'Unable to open output file '//DEC_FILE(1:DEC_FILE_LN)
	    CLOSE (UNIT=CTL_LUN)
	    CLOSE (UNIT=IBM_LUN)

	    CALL EXIT
	    END IF


! ----------------
! The main loop...
! ----------------

	DO WHILE (.TRUE.)

	    BUF_LN = REC_LEN * 4


	! ---------------------------------
	! Read a record from the input file
	! ---------------------------------

	    READ (UNIT=IBM_LUN, IOSTAT=ISTAT) IBM_BUF(1:BUF_LN)


		! ------------
		! Are we done?
		! ------------

	    IF (ISTAT .EQ. -1) THEN

	        CLOSE (UNIT=CTL_LUN)
	        CLOSE (UNIT=IBM_LUN)

	        IF (REC_CNT .GT. 0) THEN

	            CLOSE (UNIT=DEC_LUN, STATUS='KEEP')

	            TYPE *,'IBM file '//IBM_FILE(1:IBM_FILE_LN)//
	1                  ' has been converted and copied to DEC file '//
	1                  DEC_FILE(1:DEC_FILE_LN)

	            TYPE *,'Number of records processed:',REC_CNT

	        ELSE

	            CLOSE (UNIT=DEC_LUN, STATUS='DELETE')

	            TYPE *,'Input file '//IBM_FILE(1:IBM_FILE_LN)//' is empty'
	            END IF

	        CALL EXIT


		! -------------------
		! Some kind of error?
		! -------------------

	    ELSE IF (ISTAT .NE. 0) THEN

	        TYPE *,'Unable to read input file '//IBM_FILE(1:IBM_FILE_LN)

	        CLOSE (UNIT=CTL_LUN)
	        CLOSE (UNIT=IBM_LUN)
	        CLOSE (UNIT=DEC_LUN, STATUS='DELETE')

	        CALL EXIT
	        END IF


	! -----------------------------------------------------
	! Do we need to pick up a new record format descriptor?
	! -----------------------------------------------------

	    REC_CNT = REC_CNT + 1

	    IF (NRECS .EQ. 0) THEN

	        TYPE *,'The following format is in effect, '//
	1              'starting with record',
	1              REC_CNT

	        CALL IBM_TO_DEC_FMT (CTL_LUN,
	1                            IBM_LUN,
	1                            DEC_LUN,
	1                            NRECS,
	1                            FMT_CNT,
	1                            FMT_ITM,
	1                            FMT_RPT)


		! ---------------------------------------------------------
		! Compute the projected record size of the input and output
		! files
		! ---------------------------------------------------------


	        FMT_LEN = 0

	        DO I = 1, FMT_CNT

	            FMT_ITEM = FMT_ITM(I)

	            IF (FMT_ITEM .EQ. 'A') THEN		! EBCDIC field

	                FMT_LEN = FMT_LEN + FMT_RPT(I)

	            ELSE IF (FMT_ITEM .EQ. 'F') THEN	! Single-precision float

	                FMT_LEN = FMT_LEN + (FMT_RPT(I) * 4)

	            ELSE IF (FMT_ITEM .EQ. 'L') THEN	! Integer longword

	                FMT_LEN = FMT_LEN + (FMT_RPT(I) * 4)

	            ELSE IF (FMT_ITEM .EQ. 'X') THEN	! Skip byte

	                FMT_LEN = FMT_LEN + FMT_RPT(I)

	            ELSE				! All others are illegal

	                TYPE *,FMT_ITEM//' is an invalid format item'

	                CLOSE (UNIT=CTL_LUN)
	                CLOSE (UNIT=IBM_LUN)
	                CLOSE (UNIT=DEC_LUN, STATUS='DELETE')

	                CALL EXIT
	                END IF

	            END DO

	        END IF


	! --------------------------------------------------------------
	! Process the input record, producing a compatible output record
	! --------------------------------------------------------------

		! ---------------------------------------------------------
		! Make sure that the control record has enough format items
		! to cover the input file buffer record
		! ---------------------------------------------------------

	    IF (FMT_LEN .LT. BUF_LN) THEN

	        TYPE *,'Insufficient control record format item list'

	        CLOSE (UNIT=CTL_LUN)
	        CLOSE (UNIT=IBM_LUN)
	        CLOSE (UNIT=DEC_LUN, STATUS='DELETE')

	        CALL EXIT


		! ----------------------------------------------------
		! Just display a warning if it is the other way around
		! ----------------------------------------------------

	    ELSE IF (FMT_LEN .GT. BUF_LN) THEN

	        TYPE *,'Control record will only be partially utilized'
	        END IF


		! -------------------------------------
		! Perform the conversion of this record
		! -------------------------------------

	    CALL IBM_TO_DEC_CVT (IBM_BUF,
	1                        BUF_LN,
	1                        FMT_CNT,
	1                        FMT_ITM,
	1                        FMT_RPT,
	1                        DEC_BUF)

	    IF (NRECS .GT. 0) NRECS = NRECS - 1


	! -----------------------------
	! Write the output (DEC) record
	! -----------------------------

	    WRITE (UNIT=DEC_LUN, IOSTAT=ISTAT) DEC_BUF(1:BUF_LN)

	    IF (ISTAT .NE. 0) THEN

	        TYPE *,'Error writing to output file'

	        CLOSE (UNIT=CTL_LUN)
	        CLOSE (UNIT=IBM_LUN)
	        CLOSE (UNIT=DEC_LUN, STATUS='DELETE')

	        CALL EXIT
	        END IF

	    END DO

	END
