static char rcsid[] = "$Id: omniIo.c,v 1.10 2003/10/01 17:01:13 msato Exp $";
/* 
 * $RWC_Release: Omni-1.6 $
 * $RWC_Copyright:
 *  Omni Compiler Software Version 1.5-1.6
 *  Copyright (C) 2002 PC Cluster Consortium
 *  
 *  This software is free software; you can redistribute it and/or modify
 *  it under the terms of the GNU Lesser General Public License version
 *  2.1 published by the Free Software Foundation.
 *  
 *  Omni Compiler Software Version 1.0-1.4
 *  Copyright (C) 1999, 2000, 2001.
 *   Tsukuba Research Center, Real World Computing Partnership, Japan.
 *  
 *  Please check the Copyright and License information in the files named
 *  COPYRIGHT and LICENSE under the top  directory of the Omni Compiler
 *  Software release kit.
 *  
 *  
 *  $
 */
#include <stdio.h>
#include "f2c.h"
#include "lio.h"
#include "fio.h"

#ifdef USE_SCASH
#undef MT_SAFE_IO
#endif /* USE_SCASH */

#ifdef MT_SAFE_IO
#if defined(USE_UNIX_SHMEM) || defined(USE_SCASH)
static int __omniF77_using_shmem = 1;
#include "../libompsm/ompsm.h"
#elif defined(USE_STACKTHREADS)
#ifndef USE_SPIN_LOCK
#define USE_SPIN_LOCK
#endif /* !USE_SPIN_LOCK */
static int __omniF77_using_stackThreads = 1;
#include "../libompst/ompclib.h"
#undef USE_SPIN_LOCK
#else
static int __omniF77_using_threads = 1;
#include "../libompc/ompclib.h"
#endif /* (USE_UNIX_SHMEM) || (USE_SCASH) */
#include "omp.h"
#endif /* MT_SAFE_IO */

#ifdef BYTE_SWAP_IO
int byte_swap_io_flag = FALSE; /* default */
#endif /* BYTE_SWAP_IO */

#define IOTYPE_SEQUENTIAL	0
#define IOTYPE_DIRECT		1
#define IOTYPE_UNITONLY		2
#define IOTYPE_INTERNAL		3
#define IOTYPE_NAMELIST		4

typedef struct {
    int ioType;
    cilist cList;
} omniCList;

typedef struct {
    /* globals for read */
    omniCList *__curReadClist;

    /* globals for write */
    omniCList *__curWriteClist;

    /* globals for mem read */
    icilist *__curMemReadClist;

    /* globals for mem write */
    icilist *__curMemWriteClist;

    /* globals for namelist I/O */
    Vardesc **__varDescTbl;
    int __varDescNum;
    cilist *__nlCList;
    Namelist *__nmList;

    /* Giant lock variable */
#ifdef MT_SAFE_IO
    _ompc_lock_t *__curReadLock;
    _ompc_lock_t *__curWriteLock;
    _ompc_lock_t *__curMemReadLock;
    _ompc_lock_t *__curMemWriteLock;
    _ompc_lock_t *__nlLock;
#endif /* MT_SAFE_IO */
} __omniIOContext;


#ifdef MT_SAFE_IO
extern void	_ompc_enter_critical _ANSI_ARGS_((_ompc_lock_t **));
extern void	_ompc_exit_critical _ANSI_ARGS_((_ompc_lock_t **));

#define IO_R_LCK(X)	(&((X)->__curReadLock))
#define IO_W_LCK(X)	(&((X)->__curWriteLock))
#define IO_MR_LCK(X)	(&((X)->__curMemReadLock))
#define IO_MW_LCK(X)	(&((X)->__curMemWriteLock))
#define IO_NL_LCK(X)	(&((X)->__nlLock))

#define IO_InitLock(X)	\
{ \
  *(IO_R_LCK(X)) = 0; \
  *(IO_W_LCK(X)) = 0; \
  *(IO_MR_LCK(X)) = 0; \
  *(IO_MW_LCK(X)) = 0; \
  *(IO_NL_LCK(X)) = 0; \
}

#define IO_Set_R_Lock(X)	_ompc_enter_critical(IO_R_LCK(X))
#define IO_Set_W_Lock(X)	_ompc_enter_critical(IO_W_LCK(X))
#define IO_Set_MR_Lock(X)	_ompc_enter_critical(IO_MR_LCK(X))
#define IO_Set_MW_Lock(X)	_ompc_enter_critical(IO_MW_LCK(X))
#define IO_Set_NL_Lock(X)	_ompc_enter_critical(IO_NL_LCK(X))

#define IO_Unset_R_Lock(X)	_ompc_exit_critical(IO_R_LCK(X))
#define IO_Unset_W_Lock(X)	_ompc_exit_critical(IO_W_LCK(X))
#define IO_Unset_MR_Lock(X)	_ompc_exit_critical(IO_MR_LCK(X))
#define IO_Unset_MW_Lock(X)	_ompc_exit_critical(IO_MW_LCK(X))
#define IO_Unset_NL_Lock(X)	_ompc_exit_critical(IO_NL_LCK(X))

#else

#define IO_InitLock(X)		;

#define IO_Set_R_Lock(X)	;
#define IO_Set_W_Lock(X)	;
#define IO_Set_MR_Lock(X)	;
#define IO_Set_MW_Lock(X)	;
#define IO_Set_NL_Lock(X)	;

#define IO_Unset_R_Lock(X)	;
#define IO_Unset_W_Lock(X)	;
#define IO_Unset_MR_Lock(X)	;
#define IO_Unset_MW_Lock(X)	;
#define IO_Unset_NL_Lock(X)	;

#endif /* MT_SAFE_IO */

static __omniIOContext __ioCtx;
#define IO_CTXT(Y)	((&__ioCtx)->Y)

extern VOID	sig_die _ANSI_ARGS_((char *s, int kill));

static omniCList *	_initClist _ANSI_ARGS_((int ioType, int *unitPtr, char *fmt, int *recPtr,
						int errFlag, int endFlag));
static icilist *	_initMemClist _ANSI_ARGS_((char *memPtr, int memLen, char *fmt,
						   int errFlag, int endFlag));
static int	doComplexFIO _ANSI_ARGS_((char *pAddr, int pTimes, int pType));


static omniCList *
_initClist(ioType, unitPtr, fmt, recPtr, errFlag, endFlag)
     int ioType;
     int *unitPtr;
     char *fmt;
     int *recPtr;
     int errFlag;
     int endFlag;
{
    omniCList *ret = (omniCList *)malloc(sizeof(omniCList));
    if (ret == NULL) {
	sig_die("Can't allocate memory.", 1);
    }
    ret->cList.cierr = errFlag;
    ret->cList.ciunit = *unitPtr;
    ret->cList.ciend = endFlag;
    ret->cList.cifmt = fmt;
    if (recPtr == NULL) {
	ret->cList.cirec = 0;
    } else {
	ret->cList.cirec = *recPtr;
    }
    ret->ioType = ioType;

    return ret;
}


static icilist *
_initMemClist(memPtr, memLen, fmt, errFlag, endFlag)
     char *memPtr;
     int memLen;
     char *fmt;
     int errFlag;
     int endFlag;
{
    icilist *ret = (icilist *)malloc(sizeof(icilist));
    if (ret == NULL) {
	sig_die("Can't allocate memory.", 1);
    }
    ret->icierr = errFlag;
    ret->iciunit = memPtr;
    ret->iciend = endFlag;
    ret->icifmt = fmt;
    ret->icirlen = memLen;
    ret->icirnum = 1;

    return ret;    
}


void
_ompf77_IO_init()
{
#if 0
    memset((VOID *)(&__ioCtx), 0, sizeof(__omniIOContext));
    IO_InitLock(&__ioCtx);
#endif
}


int
_IO_Init_R(ioType, unitPtr, fmt, recPtr, errFlag, endFlag)
     int ioType;
     int *unitPtr;
     char *fmt;
     int *recPtr;
     int errFlag;
     int endFlag;
{
    int ret = 1;
    IO_Set_R_Lock(&(__ioCtx));

    if (IO_CTXT(__curReadClist) != NULL) {
	free(IO_CTXT(__curReadClist));
    }
    IO_CTXT(__curReadClist) = _initClist(ioType, unitPtr, fmt, recPtr, errFlag, endFlag);

    if (ioType == IOTYPE_SEQUENTIAL) {
	if (fmt == NULL) {
	    ret = s_rsle(&(IO_CTXT(__curReadClist)->cList));
	} else {
	    ret = s_rsfe(&(IO_CTXT(__curReadClist)->cList));
	}
    } else if (ioType == IOTYPE_DIRECT) {
	if (fmt == NULL) {
	    ret = s_rdue(&(IO_CTXT(__curReadClist)->cList));
	} else {
	    ret = s_rdfe(&(IO_CTXT(__curReadClist)->cList));
	}
    } else if (ioType == IOTYPE_UNITONLY) {
	ret = s_rsue(&(IO_CTXT(__curReadClist)->cList));
    } else {
	sig_die("unknown I/O type.", 1);
    }

    if (ret != 0) {
	IO_Unset_R_Lock(&(__ioCtx));
    }
    return ret;
}


int
_IO_Init_R_Mem(memPtr, memLen, fmt, errFlag, endFlag)
     char *memPtr;
     int memLen;
     char *fmt;
     int errFlag;
     int endFlag;
{
    int ret = 1;
    IO_Set_MR_Lock(&(__ioCtx));

    if (IO_CTXT(__curMemReadClist) != NULL) {
	free(IO_CTXT(__curMemReadClist));
    }
    IO_CTXT(__curMemReadClist) = _initMemClist(memPtr, memLen, fmt, errFlag, endFlag);
    if (fmt == NULL) {
	ret = s_rsli(IO_CTXT(__curMemReadClist));
    } else {
	ret = s_rsfi(IO_CTXT(__curMemReadClist));
    }

    if (ret != 0) {
	IO_Unset_MR_Lock(&(__ioCtx));
    }
    return ret;
}


int
_IO_Init_W(ioType, unitPtr, fmt, recPtr, errFlag, endFlag)
     int ioType;
     int *unitPtr;
     char *fmt;
     int *recPtr;
     int errFlag;
     int endFlag;
{
    int ret = 1;
    IO_Set_W_Lock(&(__ioCtx));

    if (IO_CTXT(__curWriteClist) != NULL) {
	free(IO_CTXT(__curWriteClist));
    }
    IO_CTXT(__curWriteClist) = _initClist(ioType, unitPtr, fmt, recPtr, errFlag, endFlag);

    if (ioType == IOTYPE_SEQUENTIAL) {
	if (fmt == NULL) {
	    ret = s_wsle(&(IO_CTXT(__curWriteClist)->cList));
	} else {
	    ret = s_wsfe(&(IO_CTXT(__curWriteClist)->cList));
	}
    } else if (ioType == IOTYPE_DIRECT) {
	if (fmt == NULL) {
	    ret = s_wdue(&(IO_CTXT(__curWriteClist)->cList));
	} else {
	    ret = s_wdfe(&(IO_CTXT(__curWriteClist)->cList));
	}
    } else if (ioType == IOTYPE_UNITONLY) {
	ret = s_wsue(&(IO_CTXT(__curWriteClist)->cList));
    } else {
	sig_die("unknown I/O type.", 1);
    }

    if (ret != 0) {
	IO_Unset_W_Lock(&(__ioCtx));
    }
    return ret;
}


int
_IO_Init_W_Mem(memPtr, memLen, fmt, errFlag, endFlag)
     char *memPtr;
     int memLen;
     char *fmt;
     int errFlag;
     int endFlag;
{
    int ret = 1;
    IO_Set_MW_Lock(&(__ioCtx));

    if (IO_CTXT(__curMemWriteClist) != NULL) {
	free(IO_CTXT(__curMemWriteClist));
    }
    IO_CTXT(__curMemWriteClist) = _initMemClist(memPtr, memLen, fmt, errFlag, endFlag);
    if (fmt == NULL) {
	ret = s_wsli(IO_CTXT(__curMemWriteClist));
    } else {
	ret = s_wsfi(IO_CTXT(__curMemWriteClist));
    }

    if (ret != 0) {
	IO_Unset_MW_Lock(&(__ioCtx));
    }
    return ret;
}


int
_IO_Clean_R()
{
    /* means positive number, error. */
    int ret = 1;

    if (IO_CTXT(__curReadClist) != NULL) {
	int ioType = IO_CTXT(__curReadClist)->ioType;
	if (ioType == IOTYPE_SEQUENTIAL) {
	    if (IO_CTXT(__curReadClist)->cList.cifmt == NULL) {
		ret = e_rsle();
	    } else {
		ret = e_rsfe();
	    }
	} else if (ioType == IOTYPE_DIRECT) {
	    if (IO_CTXT(__curReadClist)->cList.cifmt == NULL) {
		ret = e_rdue();
	    } else {
		ret = e_rdfe();
	    }
	} else if (ioType == IOTYPE_UNITONLY) {
	    ret = e_rsue();
	} else {
	    sig_die("unknown I/O type in clean up??", 1);
	}
	free(IO_CTXT(__curReadClist));
	IO_CTXT(__curReadClist) = NULL;
    }

    IO_Unset_R_Lock(&(__ioCtx));

    return ret;
}


int
_IO_Clean_R_Mem()
{
    /* means positive number, error. */
    int ret = 1;

    if (IO_CTXT(__curMemReadClist) != NULL) {
	if (IO_CTXT(__curMemReadClist)->icifmt == NULL) {
	    ret = e_rsli();
	} else {
	    ret = e_rsfi();
	}
	free(IO_CTXT(__curMemReadClist));
	IO_CTXT(__curMemReadClist) = NULL;
    }

    IO_Unset_MR_Lock(&(__ioCtx));

    return ret;
}


int
_IO_Clean_W()
{
    /* means positive number, error. */
    int ret = 1;

    if (IO_CTXT(__curWriteClist) != NULL) {
	int ioType = IO_CTXT(__curWriteClist)->ioType;
	if (ioType == IOTYPE_SEQUENTIAL) {
	    if (IO_CTXT(__curWriteClist)->cList.cifmt == NULL) {
		ret = e_wsle();
	    } else {
		ret = e_wsfe();
	    }
	} else if (ioType == IOTYPE_DIRECT) {
	    if (IO_CTXT(__curWriteClist)->cList.cifmt == NULL) {
		ret = e_wdue();
	    } else {
		ret = e_wdfe();
	    }
	} else if (ioType == IOTYPE_UNITONLY) {
	    ret = e_wsue();
	} else {
	    sig_die("unknown I/O type in clean up??", 1);
	}
	free(IO_CTXT(__curWriteClist));
	IO_CTXT(__curWriteClist) = NULL;
    }

    IO_Unset_W_Lock(&(__ioCtx));

    return ret;
}


int
_IO_Clean_W_Mem()
{
    /* means positive number, error. */
    int ret = 1;

    if (IO_CTXT(__curMemWriteClist) != NULL) {
	if (IO_CTXT(__curMemWriteClist)->icifmt == NULL) {
	    ret = e_wsli();
	} else {
	    ret = e_wsfi();
	}
	free(IO_CTXT(__curMemWriteClist));
	IO_CTXT(__curMemWriteClist) = NULL;
    }

    IO_Unset_MW_Lock(&(__ioCtx));

    return ret;
}


static int
doComplexFIO(pAddr, pTimes, pType)
     char *pAddr;
     int pTimes;
     int pType;
{
    int i;
    int ret = 1;
    int one = 1;
    
    switch (pType) {
        case TYCOMPLEX: {
            complex *cplx = (complex *)pAddr;
            for (i = 0; i < pTimes; i ++) {
                ret = do_fio((ftnint *)&one, (char *)&(cplx[i].r), sizeof(real));
                if (ret != 0) {
                    return ret;
                }
                ret = do_fio((ftnint *)&one, (char *)&(cplx[i].i), sizeof(real));
                if (ret != 0) {
                    return ret;
                }
            }
            break;
        }
        case TYDCOMPLEX: {
            doublecomplex *cplx = (doublecomplex *)pAddr;
            for (i = 0; i < pTimes; i ++) {
                ret = do_fio((ftnint *)&one, (char *)&(cplx[i].r), sizeof(doublereal));
                if (ret != 0) {
                    return ret;
                }
                ret = do_fio((ftnint *)&one, (char *)&(cplx[i].i), sizeof(doublereal));
                if (ret != 0) {
                    return ret;
                }
            }
            break;
        }
    }
    return ret;
}


int
_IO_Do_R EXC_VARARGS_DEF(int, nParam)
{
    va_list args;
    int n;
    int i;
    char *pAddr;
    ftnlen pSize;
    integer pType;
    int pTimes = 1;
    /* means positive number, error. */
    int ret = 1;
    int ioType = IO_CTXT(__curReadClist)->ioType;

    n = EXC_VARARGS_START(int, nParam, args);

    if (ioType == IOTYPE_SEQUENTIAL) {
	if (IO_CTXT(__curReadClist)->cList.cifmt != NULL) {
	    DoFIO:
	    for (i = 0; i < n; i++) {
		/* means positive number, error. */
		ret = 1;
		pAddr = (char *)va_arg(args, char *);
		pSize = (ftnlen)va_arg(args, int);
		pTimes = (int)va_arg(args, int);
		pType = (integer)va_arg(args, int);
		if (pType == TYCOMPLEX ||
		    pType == TYDCOMPLEX) {
                    ret = doComplexFIO(pAddr, pTimes, (int)pType);
		} else {
		    ret = do_fio((ftnint *)&pTimes, pAddr, pSize);
		}
		if (ret != 0) {
		    goto Done;
		}
	    }
	} else {
	    for (i = 0; i < n; i++) {
		/* means positive number, error. */
		ret = 1;
		pAddr = (char *)va_arg(args, char *);
		pSize = (ftnlen)va_arg(args, int);
		pTimes = (int)va_arg(args, int);
		pType = (integer)va_arg(args, int);
		ret = do_lio(&pType, (ftnint *)&pTimes, pAddr, pSize);
		if (ret != 0) {
		    goto Done;
		}
	    }
	}
    } else if (ioType == IOTYPE_DIRECT) {
	if (IO_CTXT(__curReadClist)->cList.cifmt != NULL) {
	    goto DoFIO;
	} else {
	    DoUIO:
	    for (i = 0; i < n; i++) {
		/* means positive number, error. */
		ret = 1;
		pAddr = (char *)va_arg(args, char *);
		pSize = (ftnlen)va_arg(args, int);
		pTimes = (int)va_arg(args, int);
		pType = (integer)va_arg(args, int);
		ret = do_uio((ftnint *)&pTimes, pAddr, pSize);
#ifdef BYTE_SWAP_IO
		if (byte_swap_io_flag == TRUE) {
		    (void)swapByte(pAddr, pType, pTimes, pSize);
		}
#endif /* BYTE_SWAP_IO */
#ifdef ENABLE_QREAL
		if (pType == TYQREAL) {
		    /*
		     * Now ((_omQreal_t *)pAddr)->_mp_d is initialized
		     * as illegal virtual address for
		     * us. Re-initialize it very here.
		     */
		    _omQReal_t *qPtr = (_omQReal_t *)pAddr;
		    qPtr->_mp_d = &(qPtr->_omLimb[0]);
		}
#endif /* ENABLE_QREAL */
		if (ret != 0) {
		    goto Done;
		}
	    }
	}
    } else if (ioType == IOTYPE_UNITONLY) {
	goto DoUIO;
    }

    Done:
    if (ret != 0) {
	IO_Unset_R_Lock(&(__ioCtx));
    }
    return ret;
}


int
_IO_Do_R_Mem EXC_VARARGS_DEF(int, nParam)
{
    va_list args;
    int n;
    int i;
    char *pAddr;
    ftnlen pSize;
    integer pType;
    int pTimes = 1;
    /* means positive number, error. */
    int ret = 1;

    n = EXC_VARARGS_START(int, nParam, args);

    if (IO_CTXT(__curMemReadClist)->icifmt != NULL) {
	for (i = 0; i < n; i++) {
	    /* means positive number, error. */
	    ret = 1;
	    pAddr = (char *)va_arg(args, char *);
	    pSize = (ftnlen)va_arg(args, int);
	    pTimes = (int)va_arg(args, int);
	    pType = (integer)va_arg(args, int);
            if (pType == TYCOMPLEX ||
                pType == TYDCOMPLEX) {
                ret = doComplexFIO(pAddr, pTimes, (int)pType);
            } else {
                ret = do_fio((ftnint *)&pTimes, pAddr, pSize);
            }            
	    if (ret != 0) {
		goto Done;
	    }
	}
    } else {
	for (i = 0; i < n; i++) {
	    /* means positive number, error. */
	    ret = 1;
	    pAddr = (char *)va_arg(args, char *);
	    pSize = (ftnlen)va_arg(args, int);
	    pTimes = (int)va_arg(args, int);
	    pType = (integer)va_arg(args, int);
	    ret = do_lio(&pType, (ftnint *)&pTimes, pAddr, pSize);
	    if (ret != 0) {
		goto Done;
	    }
	}
    }
    Done:
    if (ret != 0) {
	IO_Unset_MR_Lock(&(__ioCtx));
    }
    return ret;
}


int
_IO_Do_W EXC_VARARGS_DEF(int, nParam)
{
    va_list args;
    int n;
    int i;
    char *pAddr;
    ftnlen pSize;
    integer pType;
    int pTimes = 1;
    /* means positive number, error. */
    int ret = 1;
    int ioType = IO_CTXT(__curWriteClist)->ioType;

    n = EXC_VARARGS_START(int, nParam, args);

    if (ioType == IOTYPE_SEQUENTIAL) {
	if (IO_CTXT(__curWriteClist)->cList.cifmt != NULL) {
	    DoFIO:
	    for (i = 0; i < n; i++) {
		/* means positive number, error. */
		ret = 1;
		pAddr = (char *)va_arg(args, char *);
		pSize = (ftnlen)va_arg(args, int);
		pTimes = (int)va_arg(args, int);
		pType = (integer)va_arg(args, int);
		if (pType == TYCOMPLEX ||
		    pType == TYDCOMPLEX) {
                    ret = doComplexFIO(pAddr, pTimes, (int)pType);
		} else {
		    ret = do_fio((ftnint *)&pTimes, pAddr, pSize);
		}
		if (ret != 0) {
		    goto Done;
		}
	    }
	} else {
	    for (i = 0; i < n; i++) {
		/* means positive number, error. */
		ret = 1;
		pAddr = (char *)va_arg(args, char *);
		pSize = (ftnlen)va_arg(args, int);
		pTimes = (int)va_arg(args, int);
		pType = (integer)va_arg(args, int);
		ret = do_lio(&pType, (ftnint *)&pTimes, pAddr, pSize);
		if (ret != 0) {
		    goto Done;
		}
	    }
	}
    } else if (ioType == IOTYPE_DIRECT) {
	if (IO_CTXT(__curWriteClist)->cList.cifmt != NULL) {
	    goto DoFIO;
	} else {
	    DoUIO:
	    for (i = 0; i < n; i++) {
		/* means positive number, error. */
		ret = 1;
		pAddr = (char *)va_arg(args, char *);
		pSize = (ftnlen)va_arg(args, int);
		pTimes = (int)va_arg(args, int);
		pType = (integer)va_arg(args, int);
#ifdef ENABLE_QREAL
		/*
		 * Note:
		 *
		 * We are about to call do_uio() very here. If pType
		 * == TYQREAL, ((_omQReal_t *)pAddr)->_mp_d will be
		 * written as "raw". pAddr->_mp_d is ONLY valid for
		 * this very process. Thus, we must IGNORE
		 * pAddr->_mp_d and initialize it with
		 * &(pAddr->_omLimb[0]) when read TYQREAL. See also
		 * where calling do_uio() in _IO_Do_R().
		 *
		 * Anyway, I think it is good to initialize
		 * pAddr->_mp_d...
		 */
		if (pType == TYQREAL) {
		    _omQReal_t *qPtr = (_omQReal_t *)pAddr;
		    qPtr->_mp_d = &(qPtr->_omLimb[0]);
		}
#endif /* ENABLE_QREAL */
#ifdef BYTE_SWAP_IO
		if (byte_swap_io_flag) {
		    char *p = swapByteBuffer(pAddr, pType, pTimes, pSize);
		    if (p != NULL) {
			ret = do_uio((ftnint *)&pTimes, p, pSize);
			free(p);
		    } else {
			ret = do_uio((ftnint *)&pTimes, pAddr, pSize);
		    }
		} else {
		    ret = do_uio((ftnint *)&pTimes, pAddr, pSize);
		}
#else
		ret = do_uio((ftnint *)&pTimes, pAddr, pSize);
#endif /* BYTE_SWAP_IO */
		if (ret != 0) {
		    goto Done;
		}
	    }
	}
    } else if (ioType == IOTYPE_UNITONLY) {
	goto DoUIO;
    }

    Done:
    if (ret != 0) {
	IO_Unset_W_Lock(&(__ioCtx));
    }
    return ret;
}


int
_IO_Do_W_Mem EXC_VARARGS_DEF(int, nParam)
{
    va_list args;
    int n;
    int i;
    char *pAddr;
    ftnlen pSize;
    integer pType;
    int pTimes = 1;
    /* means positive number, error. */
    int ret = 1;

    n = EXC_VARARGS_START(int, nParam, args);

    if (IO_CTXT(__curMemWriteClist)->icifmt != NULL) {    
	for (i = 0; i < n; i++) {
	    /* means positive number, error. */
	    ret = 1;
	    pAddr = (char *)va_arg(args, char *);
	    pSize = (ftnlen)va_arg(args, int);
	    pTimes = (int)va_arg(args, int);
	    pType = (integer)va_arg(args, int);
            if (pType == TYCOMPLEX ||
                pType == TYDCOMPLEX) {
                ret = doComplexFIO(pAddr, pTimes, (int)pType);
            } else {
                ret = do_fio((ftnint *)&pTimes, pAddr, pSize);
            }
	    if (ret != 0) {
		goto Done;
	    }
	}
    } else {
	for (i = 0; i < n; i++) {
	    /* means positive number, error. */
	    ret = 1;
	    pAddr = (char *)va_arg(args, char *);
	    pSize = (ftnlen)va_arg(args, int);
	    pTimes = (int)va_arg(args, int);
	    pType = (integer)va_arg(args, int);
	    ret = do_lio(&pType, (ftnint *)&pTimes, pAddr, pSize);
	    if (ret != 0) {
		goto Done;
	    }
	}
    }
    Done:
    if (ret != 0) {
	IO_Unset_MW_Lock(&(__ioCtx));
    }
    return ret;
}


#if 0
void
dumpVardesc(v)
     Vardesc *v;
{
    int i;
    int n;
    fprintf(stderr, "\t\tvName:'%s'\n", v->name);
    fprintf(stderr, "\t\taddr:0x%08lx\n", v->addr);
    fprintf(stderr, "\t\ttype:%d\n", v->type);
    if (v->dims != NULL) {
	fprintf(stderr, "\t\tdim:%d\n", v->dims[0]);
	fprintf(stderr, "\t\tmax:%d\n", v->dims[1]);
	fprintf(stderr, "\t\toff:%d\n", v->dims[2]);
	n = v->dims[0] + 2;
	for (i = 3; i < n; i++) {
	    fprintf(stderr, "\t\t\tspec:%d\n", v->dims[i]);
	}
    }
    fprintf(stderr, "\n");
}


void
dumpNamelist(nl)
     Namelist *nl;
{
    int i;

    fprintf(stderr, "\n");
    fprintf(stderr, "\tname:'%s'\n", nl->name);

    for (i = 0; i < nl->nvars; i++) {
	dumpVardesc(nl->vars[i]);
    }
    fprintf(stderr, "\n");
}
#endif


static void
namelistInit()
{
    if (IO_CTXT(__varDescTbl) != NULL && IO_CTXT(__varDescNum) > 0) {
	int i;
	for (i = 0; i < IO_CTXT(__varDescNum); i++) {
	    free(IO_CTXT(__varDescTbl)[i]->dims);
	    free(IO_CTXT(__varDescTbl)[i]);
	}
	free(IO_CTXT(__varDescTbl));
	IO_CTXT(__varDescTbl) = NULL;
	IO_CTXT(__varDescNum) = 0;
    }
    if (IO_CTXT(__nlCList) != NULL) {
	free(IO_CTXT(__nlCList));
	IO_CTXT(__nlCList) = NULL;
    }
    if (IO_CTXT(__nmList) != NULL) {
	free(IO_CTXT(__nmList));
	IO_CTXT(__nmList) = NULL;
    }
}


void
_IO_Init_Namelist_Prolog(rw)
     int rw;
{
    IO_Set_NL_Lock(&(__ioCtx));
    namelistInit();
}


void
_IO_Init_Namelist_AddVar EXC_VARARGS_DEF(char *, varName)
{
    va_list args;
    
    char *vNm;
    int nDim;
    char *pAddr;
    int pType;
    Vardesc *vd;

    if (IO_CTXT(__varDescTbl) == NULL) {
	IO_CTXT(__varDescTbl) = (Vardesc **)malloc(sizeof(Vardesc *));
	IO_CTXT(__varDescTbl)[0] = (Vardesc *)malloc(sizeof(Vardesc));
	vd = IO_CTXT(__varDescTbl)[0];
	IO_CTXT(__varDescNum) = 1;
    } else {
	IO_CTXT(__varDescTbl) = (Vardesc **)realloc(IO_CTXT(__varDescTbl),
					   sizeof(Vardesc *) * (IO_CTXT(__varDescNum) + 1));
	IO_CTXT(__varDescTbl)[IO_CTXT(__varDescNum)] = (Vardesc *)malloc(sizeof(Vardesc));
	vd = IO_CTXT(__varDescTbl)[IO_CTXT(__varDescNum)];
	IO_CTXT(__varDescNum)++;
    }

    vNm = EXC_VARARGS_START(char *, varName, args);
    vd->name = vNm;

    pAddr = (char *)va_arg(args, char *);
    vd->addr = pAddr;
    
    pType = (int)va_arg(args, int);
    vd->type = pType;

    nDim = (int)va_arg(args, int);
    if (nDim == 0) {
	vd->dims = NULL;
    } else {
	int i;
	ftnlen *dimSpec;

	nDim += 2;
	dimSpec = (ftnlen *)malloc(sizeof(ftnlen) * nDim);

	dimSpec[0] = nDim - 2;
	for (i = 1; i < nDim; i++) {
	    dimSpec[i] = (ftnlen)va_arg(args, ftnlen);
	}
	vd->dims = dimSpec;
    }
}


void
_IO_Init_Namelist_Epilog(unitPtr, nlName, nVars, recPtr, errFlag, endFlag)
     int *unitPtr;
     char *nlName;
     int nVars;
     int *recPtr;
     int errFlag;
     int endFlag;
{
    if (IO_CTXT(__nlCList) == NULL) {
	IO_CTXT(__nlCList) = (cilist *)malloc(sizeof(cilist));
    }

    if (IO_CTXT(__nmList) == NULL) {
	IO_CTXT(__nmList) = (Namelist *)malloc(sizeof(Namelist));
    }

    IO_CTXT(__nmList)->name = nlName;
    IO_CTXT(__nmList)->vars = IO_CTXT(__varDescTbl);
    IO_CTXT(__nmList)->nvars = (nVars < IO_CTXT(__varDescNum)) ? nVars : IO_CTXT(__varDescNum);

    IO_CTXT(__nlCList)->cierr = errFlag;
    IO_CTXT(__nlCList)->ciunit = *unitPtr;
    IO_CTXT(__nlCList)->ciend = endFlag;
    IO_CTXT(__nlCList)->cifmt = (char *)IO_CTXT(__nmList);
    if (recPtr != NULL) {
	IO_CTXT(__nlCList)->cirec = *recPtr;
    } else {
	IO_CTXT(__nlCList)->cirec = 0;
    }
}


void
_IO_Clean_Namelist(rw)
     int rw;
{
    namelistInit();
    IO_Unset_NL_Lock(&(__ioCtx));
}


int
_IO_Do_W_Namelist()
{
    int ret;
    IO_Set_W_Lock(&(__ioCtx));
    ret = s_wsne(IO_CTXT(__nlCList));
    IO_Unset_W_Lock(&(__ioCtx));
    return ret;
}


int
_IO_Do_R_Namelist()
{
    int ret;
    IO_Set_R_Lock(&(__ioCtx));
    ret = s_rsne(IO_CTXT(__nlCList));
    IO_Unset_R_Lock(&(__ioCtx));
    return ret;
}


#ifdef BYTE_SWAP_IO
char *
swapByteBuffer(addr, type, count, size)
     char *addr;
     int type;
     int count;
     int size;
{
    char *p;

    switch (type) {
	case TYSHORT:
	case TYCOMPLEX:
	case TYLONG:
	case TYREAL:
	case TYDCOMPLEX:
	case TYDREAL:
#ifdef ENABLE_QREAL
	case TYQREAL:
#endif /* ENABLE_QREAL */
	case TYQUAD: {
	    if ((p = malloc(size * count)) == NULL) {
		f__fatal(113, "malloc failure");
		return NULL;
	    }
	    memcpy(p, addr, size * count);
	    if (swapByte(p, type, count, size) != TRUE) {
		free(p);
		return NULL;
	    }
	    return p;
	}
    }
    return NULL;
}


#ifdef ENABLE_QREAL
# if (OMNI_SIZEOF_QEXP_T > SIZEOF_UNSIGNED_INT)
#  define TYQEXPT	TYQUAD
# else
#  define TYQEXPT	TYLONG
# endif /* (OMNI_SIZEOF_QEXP_T > SIZEOF_UNSIGNED_INT) */
# if (OMNI_SIZEOF_QLIM_T > SIZEOF_UNSIGNED_INT)
#  define TYQLIMT	TYQUAD
# else
#  define TYQLIMT	TYLONG
# endif /* (OMNI_SIZEOF_QLIM_T > SIZEOF_UNSIGNED_INT) */
#endif /* ENABLE_QREAL */


int
swapByte(addr, type, count, size)
     char *addr;
     int type;
     int count;
     int size;
{
    struct c8 {
	unsigned char c[8];
    } *p;
    unsigned char t;
    int i;

    switch (type) {
	case TYSHORT: {
	    for (i = 0; i < count; i++) {
		p = (struct c8 *)addr;
		t = p->c[0]; p->c[0] = p->c[1]; p->c[1] = t;
		addr += size;
	    }
	    break;
	}

	case TYCOMPLEX:	count = count * 2; /* through */
	case TYLONG:
	case TYREAL: {
	    for (i = 0; i < count; i++) {
		p = (struct c8 *)addr;
		t = p->c[0]; p->c[0] = p->c[3]; p->c[3] = t;
		t = p->c[1]; p->c[1] = p->c[2]; p->c[2] = t;
		addr += size;
	    }
	    break;
	}

	case TYDCOMPLEX:	count = count * 2; /* through */
	case TYDREAL:
	case TYQUAD: {
	    for (i = 0; i < count; i++) {
		p = (struct c8 *)addr;
		t = p->c[0]; p->c[0] = p->c[7]; p->c[7] = t;
		t = p->c[1]; p->c[1] = p->c[6]; p->c[6] = t;
		t = p->c[2]; p->c[2] = p->c[5]; p->c[5] = t;
		t = p->c[3]; p->c[3] = p->c[4]; p->c[4] = t;
		addr += size;
	    }
	    break;
	}

#ifdef ENABLE_QREAL
	case TYQREAL: {
	    _omQReal_t *qPtr;
	    int *precPtr;
	    int *szPtr;
	    mp_exp_t *ePtr;
	    mp_limb_t *lPtr = NULL;
	    int j;

	    for (i = 0; i < count; i++) {
		qPtr = (_omQReal_t *)addr;
		precPtr = &(qPtr->_mp_prec);
		szPtr = &(qPtr->_mp_size);
		ePtr = &(qPtr->_mp_exp);
		(void)swapByte((char *)precPtr, TYLONG, 1, sizeof(int));
		(void)swapByte((char *)szPtr, TYLONG, 1, sizeof(int));
		(void)swapByte((char *)ePtr, TYQEXPT, 1, sizeof(mp_exp_t));

		/*
		 * Note that I DON'T swap qPtr->_mp_d at very here
		 * Because it is a virtual address of this very process!
		 * But MUST swap qPtr->_omLimb[#]!
		 */

		for (j = 0; i < gmpLimbSize; j++) {
		    lPtr = &(qPtr->_omLimb[j]);
		    (void)swapByte((char *)lPtr, TYQLIMT, 1, sizeof(mp_limb_t));
		}
		addr += size;
	    }

	    break;
	}
#endif /* ENABLE_QREAL */

	default: {
	    return FALSE;
	}
    }

    return TRUE;
}


#ifdef UIOLEN_int
# define TYUIOLEN	TYLONG
#else
# if (SIZEOF_UNSIGNED_LONG > SIZEOF_UNSIGNED_INT)
#  define TYUIOLEN	TYQUAD
# else
#  define TYUIOLEN	TYLONG
# endif
#endif /* UIOLEN_int */

void
fwrite_uiolen(lp, fp)
     uiolen *lp;
     FILE *fp;
{
    uiolen l;
    l = *lp;
    if (byte_swap_io_flag == TRUE) {
	(void)swapByte((char *)&l, TYUIOLEN, 1, sizeof(uiolen));
    }
    fwrite((char *)&l, sizeof(uiolen), 1, fp);
}


int
fread_uiolen(lp, fp)
     uiolen *lp;
     FILE *fp;
{
    if (fread((char *)lp, sizeof(uiolen), 1, fp) != 1) {
	return FALSE;
    }
    if (byte_swap_io_flag == TRUE) {
	(void)swapByte((char *)lp, TYUIOLEN, 1, sizeof(uiolen));
    }
    return TRUE;
}
#endif /* BYTE_SWAP_IO */