! ------------------------------------------------------------------------------
! PP&L VAX Computer Systems <> IBM / DEC Data Format Conversion
! -------------------------------------------------------------
!
! Given:	1. An IBM-formatted file record buffer
!		2. A conversion control format stream
!
! Do:		1. Convert the IBM buffer, field by field, into a
!		   DEC compatible buffer
!
! M. Latshaw <> 07/03/86
! ------------------------------------------------------------------------------


!			---------------------------
	SUBROUTINE	I B M _ T O _ D E C _ C V T
!			---------------------------

	1 ( IBM_BUF,	! C*(*)	Input	Input (IBM) file buffer
			!
	1   IBM_BUF_LN,	! I*4	Input	Length of input file buffer
			!
	1   FMT_CNT,	! I*4	Input	Number of items in format list
			!
	1   FMT_ITM,	! C1(*)	Input	Format item types
			!
	1   FMT_RPT,	! I4(*)	Input	Format item type repeat counts
			!
	1   DEC_BUF )	! C*(*)	Output	Output (DEC) file buffer


	IMPLICIT NONE


	INTEGER*4 LIB$TRA_EBC_ASC


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

	INTEGER*4 CUR_RPT		! Repeat factor of current format item
	INTEGER*4 DEC_BUF_LN		! Size of DEC file buffer
	INTEGER*4 FMT_CNT		! Size of format item list
	INTEGER*4 FMT_RPT(*)		! Format item list repeat counts
	INTEGER*4 I			! General index
	INTEGER*4 IBM_BUF_LN		! Size of IBM file buffer
	INTEGER*4 IRC			! Internal return status
	INTEGER*4 J			! General index
	INTEGER*4 K			! General index
	INTEGER*4 L			! General index
	INTEGER*4 M			! General index
	INTEGER*4 N			! General index

	EXTERNAL SS$_NORMAL


! -------------
! Preliminaries
! -------------

	DEC_BUF_LN = 0


! ------------------
! Process the buffer
! ------------------

	DO I = 1, FMT_CNT


	! --------------------------
	! All done with this record?
	! --------------------------

	    IF (DEC_BUF_LN .GE. IBM_BUF_LN) RETURN


	! ----------------------------------
	! If not, get ready for another pass
	! ----------------------------------

	    CUR_ITM = FMT_ITM(I)
	    CUR_RPT = FMT_RPT(I)
	    J       = DEC_BUF_LN + 1


	! ------
	! EBCDIC
	! ------

	    IF (CUR_ITM .EQ. 'A') THEN


		! -----------------------------------------------------
		! Don't attempt to process beyond the end of the record
		! -----------------------------------------------------

	        L = DEC_BUF_LN + CUR_RPT

	        IF (L .GT. IBM_BUF_LN) THEN

	            K = IBM_BUF_LN - DEC_BUF_LN

	        ELSE

	            K = CUR_RPT
	            END IF

	        K = DEC_BUF_LN + K


		! ---------
		! Translate
		! ---------

	        IRC = LIB$TRA_EBC_ASC (IBM_BUF(J:K), DEC_BUF(J:K))

	        IF (IRC .NE. %LOC (SS$_NORMAL)) THEN

	            TYPE *,'Warning --- EBCDIC / ASCII translation failed'
	            END IF


	! ----------------
	! Integer Longword
	! ----------------

	    ELSE IF (CUR_ITM .EQ. 'L') THEN


		! -----------------------------------------------------
		! Don't attempt to process beyond the end of the record
		! -----------------------------------------------------

	        L = DEC_BUF_LN + (CUR_RPT * 4)

	        IF (L .GT. IBM_BUF_LN) THEN

	            M = (IBM_BUF_LN - DEC_BUF_LN) / 4

	            IF (M .EQ. 0) THEN

	                TYPE *,'Control record format item mismatch'
	                CALL EXIT
	                END IF

	        ELSE

	            M = CUR_RPT
	            END IF

	        N = M * 4
	        K = DEC_BUF_LN + N


		! ---------
		! Translate
		! ---------

	        DEC_BUF(J:K) = IBM_BUF(J:K)

	        CALL IBMI4 (M, %REF (DEC_BUF(J:K)))


	! -------------------------------
	! Single-precision floating point
	! -------------------------------

	    ELSE IF (CUR_ITM .EQ. 'F') THEN


		! -----------------------------------------------------
		! Don't attempt to process beyond the end of the record
		! -----------------------------------------------------

	        L = DEC_BUF_LN + (CUR_RPT * 4)

	        IF (L .GT. IBM_BUF_LN) THEN

	            M = (IBM_BUF_LN - DEC_BUF_LN) / 4

	            IF (M .EQ. 0) THEN

	                TYPE *,'Control record format item mismatch'
	                CALL EXIT
	                END IF

	        ELSE

	            M = CUR_RPT
	            END IF

	        N = M * 4
	        K = DEC_BUF_LN + N


		! ---------
		! Translate
		! ---------

	        DEC_BUF(J:K) = IBM_BUF(J:K)

	        CALL CVT_IBM_DEC_F (M, %REF (DEC_BUF(J:K)))


	! ---------
	! Skip byte
	! ---------

	    ELSE IF (CUR_ITM .EQ. 'X') THEN


		! -----------------------------------------------------
		! Don't attempt to process beyond the end of the record
		! -----------------------------------------------------

	        L = DEC_BUF_LN + CUR_RPT

	        IF (L .GT. IBM_BUF_LN) THEN

	            K = IBM_BUF_LN - DEC_BUF_LN

	        ELSE

	            K = CUR_RPT
	            END IF

	        K            = DEC_BUF_LN + K
	        DEC_BUF(J:K) = IBM_BUF(J:K)
	        END IF


	    DEC_BUF_LN = K			! Update the accumulative length
	    END DO

	END








































