pkg/mdsio/mdsio_write_whalos.F

d7fbd5d0c9 Gael*0001 #include "MDSIO_OPTIONS.h"
                0002
                0003 CBOP
9f5240b52a Jean*0004 C     !ROUTINE: MDS_WRITE_WHALOS
d7fbd5d0c9 Gael*0005 C     !INTERFACE:
9f5240b52a Jean*0006       SUBROUTINE MDS_WRITE_WHALOS(
d7fbd5d0c9 Gael*0007      I                    fName,
                0008      I                    len,
                0009      I                    filePrec,
                0010      I                    fid,
                0011      I                    n2d,
                0012      I                    fldRL,
                0013      I                    irec,
9231496966 Gael*0014      I                    locSingleCPUIO,
ab63ca39fb Gael*0015      I                    locBufferIO,
9f5240b52a Jean*0016      I                    myThid )
d7fbd5d0c9 Gael*0017
                0018 C     !DESCRIPTION: \bv
9f5240b52a Jean*0019 C     ==================================================================
                0020 C     SUBROUTINE MDS_WRITE_WHALOS
                0021 C     o Write file that includes halos. The main purpose is for
                0022 C       adjoint related "tape I/O". The secondary purpose is debugging.
                0023 C     ==================================================================
d7fbd5d0c9 Gael*0024 C     \ev
                0025
                0026 C     !USES:
9f5240b52a Jean*0027       IMPLICIT NONE
d7fbd5d0c9 Gael*0028
9f5240b52a Jean*0029 C     == global variables ==
d7fbd5d0c9 Gael*0030 #include "EEPARAMS.h"
                0031 #include "SIZE.h"
                0032 #include "PARAMS.h"
                0033 #ifdef ALLOW_WHIO
                0034 # include "MDSIO_BUFF_WH.h"
                0035 #endif
                0036
                0037 C     !INPUT/OUTPUT PARAMETERS:
9f5240b52a Jean*0038 C     fName    ::  extended tape fName.
                0039 C     len      ::  number of characters in fName.
                0040 C     filePrec ::  number of bits per word in file (32 or 64).
                0041 C     fid      ::  file unit (its use is not implemented yet).
                0042 C     n2d      ::  size of the fldRL third dimension.
                0043 C     fldRL    ::  array to read.
                0044 C     irec     ::  record number to be written.
                0045 C     myThid   ::  my Thread Id number
                0046       CHARACTER*(*) fName
                0047       INTEGER len
                0048       INTEGER filePrec
                0049       INTEGER fid
                0050       INTEGER n2d
                0051       _RL     fldRL(1-OLx:sNx+OLx,1-OLy:sNy+OLy,n2d,nSx,nSy)
                0052       INTEGER irec
                0053       LOGICAL locSingleCPUIO, locBufferIO
                0054       INTEGER myThid
d7fbd5d0c9 Gael*0055
                0056 #ifdef ALLOW_WHIO
9f5240b52a Jean*0057 C     !FUNCTIONS:
                0058       INTEGER  ILNBLNK
                0059       INTEGER  MDS_RECLEN
                0060       EXTERNAL ILNBLNK
                0061       EXTERNAL MDS_RECLEN
d7fbd5d0c9 Gael*0062
9f5240b52a Jean*0063 C     !LOCAL VARIABLES:
                0064 C     == local parameters ==
                0065 C     sNxWh   :: x tile size with halo included
                0066 C     sNyWh   :: y tile size with halo included
d7fbd5d0c9 Gael*0067 C     pocNyWh :: processor sum of sNyWh
                0068 C     gloNyWh :: global sum of sNyWh
                0069       INTEGER sNxWh
                0070       INTEGER sNyWh
                0071       INTEGER procNyWh
                0072       INTEGER gloNyWh
9f5240b52a Jean*0073       PARAMETER ( sNxWh = sNx+2*OLx )
                0074       PARAMETER ( sNyWh = sNy+2*OLy )
d7fbd5d0c9 Gael*0075       PARAMETER ( procNyWh = sNyWh*nSy*nSx )
                0076       PARAMETER ( gloNyWh = procNyWh*nPy*nPx )
9f5240b52a Jean*0077 C     == local variables ==
                0078       CHARACTER*(MAX_LEN_FNAM) pfName
                0079       INTEGER IL
                0080       INTEGER lengthBuff, length_of_rec
                0081       INTEGER i, j, i2d
                0082       INTEGER dUnit, irec2d
d7fbd5d0c9 Gael*0083       LOGICAL iAmDoingIO
01e0ec14d7 Jean*0084 #ifdef ALLOW_WHIO_3D
                0085       INTEGER js
                0086 #endif
9f5240b52a Jean*0087 CEOP
d7fbd5d0c9 Gael*0088
ab63ca39fb Gael*0089 #ifdef ALLOW_WHIO_3D
                0090       writeWh=.TRUE.
                0091 #endif
d7fbd5d0c9 Gael*0092
9f5240b52a Jean*0093       IF ( .NOT.locSingleCpuIO ) THEN
ab63ca39fb Gael*0094         lengthBuff=sNxWh*procNyWh
                0095       ELSE
                0096         lengthBuff=sNxWh*gloNyWh
                0097       ENDIF
1d8c557c39 Jean*0098
9231496966 Gael*0099 C Only do I/O if I am the master thread (and mpi process 0 IF locSingleCpuIO):
                0100       iAmDoingIO = .FALSE.
                0101       IF ( .NOT.locSingleCpuIO .OR. myProcId.EQ.0 ) THEN
                0102         _BEGIN_MASTER( myThid )
                0103         iAmDoingIO = .TRUE.
                0104         _END_MASTER( myThid )
1d8c557c39 Jean*0105       ENDIF
9231496966 Gael*0106
d7fbd5d0c9 Gael*0107       IF ( iAmDoingIO ) THEN
9f5240b52a Jean*0108 C get the unit and open file
d7fbd5d0c9 Gael*0109       IL  = ILNBLNK( fName )
9231496966 Gael*0110       IF ( .NOT.locSingleCpuIO ) THEN
                0111         WRITE(pfName,'(2A,I3.3,A)') fName(1:IL),'.',myProcId,'.data'
d7fbd5d0c9 Gael*0112         length_of_rec = MDS_RECLEN( filePrec,sNxWh*procNyWh,myThid )
                0113       ELSE
9231496966 Gael*0114         WRITE(pfName,'(2A)') fName(1:IL),'.data'
d7fbd5d0c9 Gael*0115         length_of_rec = MDS_RECLEN( filePrec,sNxWh*gloNyWh,myThid)
                0116       ENDIF
9231496966 Gael*0117       IF (fid.EQ.0) THEN
                0118         CALL MDSFINDUNIT( dUnit, myThid )
                0119         OPEN( dUnit, file=pfName, status='unknown',
d7fbd5d0c9 Gael*0120      &         access='direct', recl=length_of_rec )
9231496966 Gael*0121       ELSE
                0122         dUnit=fid
                0123       ENDIF
d7fbd5d0c9 Gael*0124       ENDIF
f6d7c45cef Jean*0125
9f5240b52a Jean*0126       DO i2d=1,n2d
d7fbd5d0c9 Gael*0127
                0128         IF (filePrec .EQ. precFloat32) THEN
1cfc927d8c Jean*0129           CALL MDS_PASS_R4toRL( fld2d_procbuff_r4, fldRL,
                0130      &             OLx, OLy, 1, i2d, n2d, 0, 0, .FALSE., myThid )
9f5240b52a Jean*0131           IF ( locSingleCpuIO ) THEN
d7fbd5d0c9 Gael*0132             CALL BAR2( myThid )
ab63ca39fb Gael*0133 #  ifndef EXCLUDE_WHIO_GLOBUFF_2D
f6d7c45cef Jean*0134             CALL GATHER_2D_WH_R4( fld2d_globuff_r4,
d7fbd5d0c9 Gael*0135      &                            fld2d_procbuff_r4,myThid)
ab63ca39fb Gael*0136 #  endif
f6d7c45cef Jean*0137           ENDIF
d7fbd5d0c9 Gael*0138         ELSE
1cfc927d8c Jean*0139           CALL MDS_PASS_R8toRL( fld2d_procbuff_r8, fldRL,
                0140      &             OLx, OLy, 1, i2d, n2d, 0, 0, .FALSE., myThid )
9f5240b52a Jean*0141           IF ( locSingleCpuIO ) THEN
d7fbd5d0c9 Gael*0142             CALL BAR2( myThid )
ab63ca39fb Gael*0143 #  ifndef EXCLUDE_WHIO_GLOBUFF_2D
f6d7c45cef Jean*0144             CALL GATHER_2D_WH_R8( fld2d_globuff_r8,
d7fbd5d0c9 Gael*0145      &                            fld2d_procbuff_r8,myThid)
ab63ca39fb Gael*0146 #  endif
f6d7c45cef Jean*0147           ENDIF
d7fbd5d0c9 Gael*0148         ENDIF
                0149
                0150         _BARRIER
ab63ca39fb Gael*0151 #ifdef ALLOW_WHIO_3D
                0152         IF ( iAmDoingIO.AND.locBufferIO.AND.(fid.NE.0) ) THEN
9f5240b52a Jean*0153 C reset counter if needed
ab63ca39fb Gael*0154           IF (jWh.EQ.nWh) jWh=0
9f5240b52a Jean*0155 C increment counter
ab63ca39fb Gael*0156           jWh=jWh+1
9f5240b52a Jean*0157 C determine current file record
ab63ca39fb Gael*0158           irec2d=i2d+n2d*(irec-1)
                0159           iWh=(irec2d-1)/nWh+1
9f5240b52a Jean*0160 C copy
01e0ec14d7 Jean*0161           js = (jWh-1)*lengthBuff
                0162           IF ( .NOT.locSingleCpuIO ) THEN
                0163             IF (filePrec .EQ. precFloat32) THEN
                0164               DO i=1,lengthBuff
                0165                 j = js + i
                0166                 fld3d_procbuff_r4(j) = fld2d_procbuff_r4(i)
                0167               ENDDO
ab63ca39fb Gael*0168             ELSE
01e0ec14d7 Jean*0169               DO i=1,lengthBuff
                0170                 j = js + i
                0171                 fld3d_procbuff_r8(j) = fld2d_procbuff_r8(i)
                0172               ENDDO
                0173             ENDIF
                0174           ELSE
ab63ca39fb Gael*0175 #  ifdef INCLUDE_WHIO_GLOBUFF_3D
01e0ec14d7 Jean*0176             IF (filePrec .EQ. precFloat32) THEN
                0177               DO i=1,lengthBuff
                0178                 j = js + i
                0179                 fld3d_globuff_r4(j) = fld2d_globuff_r4(i)
                0180               ENDDO
                0181             ELSE
                0182               DO i=1,lengthBuff
                0183                 j = js + i
                0184                 fld3d_globuff_r8(j) = fld2d_globuff_r8(i)
                0185               ENDDO
ab63ca39fb Gael*0186             ENDIF
01e0ec14d7 Jean*0187 #  endif
                0188           ENDIF
9f5240b52a Jean*0189 C write chunk if needed
ab63ca39fb Gael*0190           IF (jWh.EQ.nWh) THEN
9f5240b52a Jean*0191             IF ( .NOT.locSingleCpuIO ) THEN
ab63ca39fb Gael*0192               IF (filePrec .EQ. precFloat32) THEN
                0193                 WRITE(dUnit,rec=iWh) fld3d_procbuff_r4
                0194               ELSE
                0195                 WRITE(dUnit,rec=iWh) fld3d_procbuff_r8
                0196               ENDIF
                0197             ELSE
                0198 #  ifdef INCLUDE_WHIO_GLOBUFF_3D
                0199               IF (filePrec .EQ. precFloat32) THEN
                0200                 WRITE(dUnit,rec=iWh) fld3d_globuff_r4
                0201               ELSE
                0202                 WRITE(dUnit,rec=iWh) fld3d_globuff_r8
                0203               ENDIF
                0204 #  endif
                0205             ENDIF
                0206           ENDIF
                0207
                0208         ELSEIF ( iAmDoingIO ) THEN
01e0ec14d7 Jean*0209 #else /* ALLOW_WHIO_3D */
d7fbd5d0c9 Gael*0210         IF ( iAmDoingIO ) THEN
01e0ec14d7 Jean*0211 #endif /* ALLOW_WHIO_3D */
9231496966 Gael*0212           irec2d=i2d+n2d*(irec-1)
9f5240b52a Jean*0213           IF ( .NOT.locSingleCpuIO ) THEN
d7fbd5d0c9 Gael*0214             IF (filePrec .EQ. precFloat32) THEN
                0215               WRITE(dUnit,rec=irec2d) fld2d_procbuff_r4
                0216             ELSE
                0217               WRITE(dUnit,rec=irec2d) fld2d_procbuff_r8
                0218             ENDIF
                0219           ELSE
ab63ca39fb Gael*0220 #  ifndef EXCLUDE_WHIO_GLOBUFF_2D
d7fbd5d0c9 Gael*0221             IF (filePrec .EQ. precFloat32) THEN
                0222               WRITE(dUnit,rec=irec2d) fld2d_globuff_r4
                0223             ELSE
                0224               WRITE(dUnit,rec=irec2d) fld2d_globuff_r8
                0225             ENDIF
ab63ca39fb Gael*0226 #  endif
d7fbd5d0c9 Gael*0227           ENDIF
                0228         ENDIF
                0229         _BARRIER
                0230
9f5240b52a Jean*0231       ENDDO
f6d7c45cef Jean*0232
9231496966 Gael*0233       IF ( iAmDoingIO.AND.(fid.EQ.0) ) THEN
d7fbd5d0c9 Gael*0234         CLOSE( dUnit )
                0235       ENDIF
                0236
01e0ec14d7 Jean*0237 #endif /* ALLOW_WHIO */
d7fbd5d0c9 Gael*0238
1d8c557c39 Jean*0239       RETURN
                0240       END