pkg/mdsio/mdsio_facef_read.F

6a2139a6bc Jean*0001 #include "MDSIO_OPTIONS.h"
                0002
                0003 C--  File mdsio_read_facefile.F:
                0004 C--   Contents
                0005 C--   o MDS_FACEF_READ_RS
                0006 C--   o MDS_FACEF_READ_RL  <- not yet coded
                0007
                0008 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0009
                0010 CBOP
                0011 C     !ROUTINE:  MDS_FACEF_READ_RS
                0012 C     !INTERFACE:
                0013       SUBROUTINE MDS_FACEF_READ_RS(
                0014      I                    fName, fPrec, irec,
                0015      U                    array,
                0016      I                    bi,bj, myThid )
                0017 C     !DESCRIPTION: \bv
                0018 C     *==========================================================*
                0019 C     | SUBROUTINE MDS_FACEF_READ_RS
                0020 C     *==========================================================*
                0021 C     | Read 1 field from a file which contains all the data from
                0022 C     |  1 "face" (= piece of domain with rectangular topology)
                0023 C     *==========================================================*
                0024 C     \ev
                0025
                0026 C     !USES:
                0027       IMPLICIT NONE
                0028 C     === Global variables ===
                0029 #include "SIZE.h"
                0030 #include "EEPARAMS.h"
                0031 #ifdef ALLOW_EXCH2
f9f661930b Jean*0032 #include "W2_EXCH2_SIZE.h"
6a2139a6bc Jean*0033 #include "W2_EXCH2_TOPOLOGY.h"
                0034 #endif /* ALLOW_EXCH2 */
                0035
                0036 C     !INPUT/OUTPUT PARAMETERS:
                0037 C     == Routine arguments ==
                0038       CHARACTER*(*) fName
                0039       INTEGER fPrec
                0040       INTEGER irec
                0041       _RS array(1-Olx:sNx+Olx,1-Oly:sNy+Oly,nSx,nSy)
                0042       INTEGER bi,bj, myThid
                0043 CEOP
                0044
                0045 C     !FUNCTIONS:
                0046       INTEGER  MDS_RECLEN
                0047       EXTERNAL MDS_RECLEN
                0048       INTEGER  ILNBLNK
                0049       EXTERNAL ILNBLNK
                0050
                0051 C     !LOCAL VARIABLES:
                0052 C     == Local variables ==
                0053       INTEGER i,j, dUnit, iLen
                0054       INTEGER length_of_rec
                0055       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0056 #ifdef ALLOW_EXCH2
                0057       INTEGER tN, dNx, dNy, tBx, tBy, tNx, tNY, jj, jBase
                0058       Real*4 ioBuf4(1:sNx*nSx*nPx+1)
                0059       Real*8 ioBuf8(1:sNx*nSx*nPx+1)
                0060 #else
                0061       Real*4 ioBuf4(1:sNx+1,1:sNy+1)
                0062       Real*8 ioBuf8(1:sNx+1,1:sNy+1)
                0063 #endif /* ALLOW_EXCH2 */
                0064
                0065       iLen = ILNBLNK(fName)
                0066 #ifdef ALLOW_EXCH2
                0067 C     Figure out offset of tile within face
c424ee7cc7 Jean*0068       tN  = W2_myTileList(bi,bj)
6a2139a6bc Jean*0069       dNx = exch2_mydnx(tN)
                0070       dNy = exch2_mydny(tN)
                0071       tBx = exch2_tbasex(tN)
                0072       tBy = exch2_tbasey(tN)
                0073       tNx = exch2_tnx(tN)
                0074       tNy = exch2_tny(tN)
                0075
                0076       CALL MDSFINDUNIT( dUnit, myThid )
                0077       length_of_rec = MDS_RECLEN( fPrec, (dNx+1), myThid )
3d93c0a01e Ou W*0078       OPEN( dUnit, file=fName(1:iLen), status='old', _READONLY_ACTION
6a2139a6bc Jean*0079      &             access='direct', recl=length_of_rec )
                0080       j = 0
                0081       jBase=(irec-1)*(dNy+1)
                0082       IF ( fPrec.EQ.precFloat32 ) THEN
                0083         DO jj=1+tBy,sNy+1+tBy
                0084          READ(dUnit,rec=jj+jBase) (ioBuf4(i),i=1,dNx+1)
                0085 #ifdef _BYTESWAPIO
                0086          CALL MDS_BYTESWAPR4( (dNx+1), ioBuf4 )
                0087 #endif
                0088          j = j+1
                0089          DO i=1,sNx+1
                0090           array(i,j,bi,bj) = ioBuf4(i+tBx)
                0091          ENDDO
                0092         ENDDO
                0093       ELSEIF ( fPrec.EQ.precFloat64 ) THEN
                0094         DO jj=1+tBy,sNy+1+tBy
                0095          READ(dUnit,rec=jj+jBase) (ioBuf8(i),i=1,dNx+1)
                0096 #ifdef _BYTESWAPIO
                0097          CALL MDS_BYTESWAPR8( (dNx+1), ioBuf8 )
                0098 #endif
                0099          j = j+1
                0100          DO i=1,sNx+1
                0101           array(i,j,bi,bj) = ioBuf8(i+tBx)
                0102          ENDDO
                0103         ENDDO
                0104       ELSE
                0105         WRITE(msgBuf,'(A,I8,A)')  ' MDS_FACEF_READ_RS:',
                0106      &             fPrec, ' = illegal value for fPrec'
                0107         CALL PRINT_ERROR( msgBuf, myThid )
                0108         STOP 'ABNORMAL END: S/R MDS_FACEF_READ_RS'
                0109       ENDIF
                0110       CLOSE( dUnit )
                0111
                0112 #else /* ALLOW_EXCH2 */
                0113
                0114       CALL MDSFINDUNIT( dUnit, myThid )
                0115       length_of_rec = MDS_RECLEN( fPrec, (sNx+1)*(sNy+1), myThid )
3d93c0a01e Ou W*0116       OPEN( dUnit, file=fName(1:iLen), status='old', _READONLY_ACTION
6a2139a6bc Jean*0117      &             access='direct', recl=length_of_rec )
                0118       IF ( fPrec.EQ.precFloat32 ) THEN
                0119         READ(dUnit, rec=irec) ioBuf4
                0120 #ifdef _BYTESWAPIO
                0121         CALL MDS_BYTESWAPR4( (sNx+1)*(sNy+1), ioBuf4 )
                0122 #endif
                0123         DO j=1,sNy+1
                0124          DO i=1,sNx+1
                0125           array(i,j,bi,bj) = ioBuf4(i,j)
                0126          ENDDO
                0127         ENDDO
                0128       ELSEIF ( fPrec.EQ.precFloat64 ) THEN
                0129         READ(dUnit, rec=irec) ioBuf8
                0130 #ifdef _BYTESWAPIO
                0131         CALL MDS_BYTESWAPR8( (sNx+1)*(sNy+1), ioBuf8 )
                0132 #endif
                0133         DO j=1,sNy+1
                0134          DO i=1,sNx+1
                0135           array(i,j,bi,bj) = ioBuf8(i,j)
                0136          ENDDO
                0137         ENDDO
                0138       ELSE
                0139         WRITE(msgBuf,'(A,I8,A)')  ' MDS_FACEF_READ_RS:',
                0140      &             fPrec, ' = illegal value for fPrec'
                0141         CALL PRINT_ERROR( msgBuf, myThid )
                0142         STOP 'ABNORMAL END: S/R MDS_FACEF_READ_RS'
                0143       ENDIF
                0144       CLOSE( dUnit )
                0145
                0146 #endif /* ALLOW_EXCH2 */
                0147
                0148 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0149
                0150       RETURN
                0151       END