pkg/mdsio/mdsio_wr_rec_rl.F

ddb868624b Jean*0001 #include "MDSIO_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP 0
                0005 C !ROUTINE: MDS_WR_REC_RL
                0006
                0007 C !INTERFACE:
                0008       SUBROUTINE MDS_WR_REC_RL(
                0009      I                          arr,
                0010      O                          r4Buf, r8Buf,
                0011      I                          fPrec, dUnit, iRec, nArr, myThid )
                0012
                0013 C !DESCRIPTION:
                0014 C Write one reccord to already opened io-unit "dUnit", from RL array "arr"
                0015
                0016 C !USES:
                0017       IMPLICIT NONE
                0018 #include "EEPARAMS.h"
                0019 #include "SIZE.h"
                0020 #include "PARAMS.h"
                0021
                0022 C !INPUT PARAMETERS:
                0023 C   arr     RL     :: vector array to write
                0024 C   fPrec  integer :: file precision
                0025 C   dUnit  integer :: 'Opened' I/O channel
                0026 C   iRec   integer :: record number to WRITE
                0027 C   nArr   integer :: dimension off array "arr"
                0028 C   myThid integer :: my Thread Id number
                0029 C !OUTPUT PARAMETERS:
                0030 C   r4Buf  real*4  :: buffer array
                0031 C   r8Buf  real*8  :: buffer array
                0032       INTEGER fPrec
                0033       INTEGER dUnit
                0034       INTEGER iRec
                0035       INTEGER nArr
                0036       INTEGER myThid
                0037       _RL    arr(nArr)
                0038       Real*4 r4Buf(nArr)
                0039       Real*8 r8Buf(nArr)
                0040 CEOP
                0041
                0042 C !LOCAL VARIABLES:
                0043       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0044       INTEGER k
                0045
                0046 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
ef8a09518b Jean*0047       IF ( debugLevel.GE.debLevD ) THEN
ddb868624b Jean*0048         WRITE(msgBuf,'(A,I9,2x,I9)')
                0049      &      ' MDS_WR_REC_RL: iRec,Dim = ', iRec, nArr
                0050         CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
                0051      &                      SQUEEZE_RIGHT , myThid )
                0052       ENDIF
                0053
                0054       IF ( fPrec.EQ.precFloat32 ) THEN
                0055         DO k=1,nArr
                0056           r4Buf(k) = arr(k)
                0057         ENDDO
                0058 #ifdef _BYTESWAPIO
                0059         CALL MDS_BYTESWAPR4( nArr, r4Buf )
                0060 #endif
                0061         WRITE( dUnit, rec=iRec ) r4Buf
                0062       ELSEIF ( fPrec.EQ.precFloat64 ) THEN
                0063         DO k=1,nArr
                0064           r8Buf(k) = arr(k)
                0065         ENDDO
                0066 #ifdef _BYTESWAPIO
                0067         CALL MDS_BYTESWAPR8( nArr, r8Buf )
                0068 #endif
                0069         WRITE( dUnit, rec=iRec ) r8Buf
                0070       ELSE
                0071         WRITE(msgBuf,'(A,I9)')
                0072      &        ' MDS_WR_REC_RL: illegal value for fPrec=',fPrec
                0073         CALL PRINT_ERROR( msgBuf, myThid )
                0074         STOP 'ABNORMAL END: S/R MDS_WR_REC_RL'
                0075       ENDIF
                0076
                0077       RETURN
                0078       END