pkg/mdsio/mdsio_gl.F

6d54cf9ca1 Ed H*0001 #include "MDSIO_OPTIONS.h"
5ae46f2adb Patr*0002
b714306922 Jean*0003 C--  File mdsio_gl.F: Routines to handle mid-level I/O interface.
                0004 C--   Contents
                0005 C--   o MDSREADFIELD_3D_GL
                0006 C--   o MDSWRITEFIELD_3D_GL
                0007 C--   o MDSREADFIELD_2D_GL
                0008 C--   o MDSWRITEFIELD_2D_GL
                0009
                0010 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
5ae46f2adb Patr*0011
                0012       SUBROUTINE MDSREADFIELD_3D_GL(
ffa487b126 Alis*0013      I   fName,
                0014      I   filePrec,
                0015      I   arrType,
                0016      I   nNz,
                0017      O   arr_gl,
                0018      I   irecord,
                0019      I   myThid )
                0020 C
                0021 C Arguments:
                0022 C
eb5e2b9a92 Jean*0023 C fName     (string)  :: base name for file to read
                0024 C filePrec  (integer) :: number of bits per word in file (32 or 64)
                0025 C arrType   (char(2)) :: type of array "arr": either "RS" or "RL"
                0026 C nNz       (integer) :: size of third dimension: normally either 1 or Nr
                0027 C arr        (RS/RL)  :: array to read into, arr(:,:,nNz,:,:)
                0028 C irecord   (integer) :: record number to read
                0029 C myThid    (integer) :: thread identifier
ffa487b126 Alis*0030 C
                0031 C MDSREADFIELD first checks to see if the file "fName" exists, then
                0032 C if the file "fName.data" exists and finally the tiled files of the
                0033 C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
                0034 C read because it is difficult to parse files in fortran.
                0035 C The precision of the file is decsribed by filePrec, set either
                0036 C to floatPrec32 or floatPrec64. The precision or declaration of
                0037 C the array argument must be consistently described by the char*(2)
                0038 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
                0039 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
                0040 C nNz=Nr implies a 3-D model field. irecord is the record number
                0041 C to be read and must be >= 1. The file data is stored in
                0042 C arr *but* the overlaps are *not* updated. ie. An exchange must
                0043 C be called. This is because the routine is sometimes called from
                0044 C within a MASTER_THID region.
                0045 C
5ae46f2adb Patr*0046 C Created: 03/16/99 adcroft@mit.edu
ffa487b126 Alis*0047
                0048       implicit none
                0049 C Global variables / common blocks
                0050 #include "SIZE.h"
                0051 #include "EEPARAMS.h"
                0052 #include "PARAMS.h"
                0053
                0054 C Routine arguments
                0055       character*(*) fName
                0056       integer filePrec
                0057       character*(2) arrType
                0058       integer nNz
5ae46f2adb Patr*0059       _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
ffa487b126 Alis*0060       integer irecord
                0061       integer myThid
de7dc9fe18 Oliv*0062
                0063 #ifdef ALLOW_CTRL
                0064
ffa487b126 Alis*0065 C Functions
                0066       integer ILNBLNK
                0067       integer MDS_RECLEN
                0068 C Local variables
47c8a35ff3 Jean*0069       character*(MAX_LEN_FNAM) dataFName
7ac755d99f Patr*0070       integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
ffa487b126 Alis*0071       logical exst
                0072       _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
                0073       Real*4 r4seg(sNx)
                0074       Real*8 r8seg(sNx)
                0075       logical globalFile,fileIsOpen
                0076       integer length_of_rec
                0077       character*(max_len_mbuf) msgbuf
eda676cb0f Patr*0078 cph-usesingle(
                0079       integer ii,jj
47c8a35ff3 Jean*0080 c     integer iG_IO,jG_IO,npe
                0081       integer x_size,y_size
eda676cb0f Patr*0082       PARAMETER ( x_size = Nx )
                0083       PARAMETER ( y_size = Ny )
                0084       Real*4 xy_buffer_r4(x_size,y_size)
                0085       Real*8 xy_buffer_r8(x_size,y_size)
                0086       Real*8 global(Nx,Ny)
47c8a35ff3 Jean*0087 c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
eda676cb0f Patr*0088 cph-usesingle)
6a53f18a53 Patr*0089 CMM(
                0090       integer pIL
                0091 CMM)
eda676cb0f Patr*0092
ffa487b126 Alis*0093 C     ------------------------------------------------------------------
                0094
                0095 C Only do I/O if I am the master thread
                0096       _BEGIN_MASTER( myThid )
                0097
b2fffc7e1a Jean*0098 #ifndef REAL4_IS_SLOW
                0099       if (arrType .eq. 'RS') then
                0100        write(msgbuf,'(a)')
                0101      &   ' MDSREADFIELD_GL is wrong for arrType="RS" (=real*4)'
                0102        call print_error( msgbuf, mythid )
                0103        stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                0104       endif
                0105 #endif
                0106
ffa487b126 Alis*0107 C Record number must be >= 1
                0108       if (irecord .LT. 1) then
                0109        write(msgbuf,'(a,i9.8)')
                0110      &   ' MDSREADFIELD_GL: argument irecord = ',irecord
                0111        call print_message( msgbuf, standardmessageunit,
                0112      &                     SQUEEZE_RIGHT , mythid)
                0113        write(msgbuf,'(a)')
                0114      &   ' MDSREADFIELD_GL: Invalid value for irecord'
                0115        call print_error( msgbuf, mythid )
                0116        stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                0117       endif
                0118
                0119 C Assume nothing
                0120       globalFile = .FALSE.
                0121       fileIsOpen = .FALSE.
                0122       IL=ILNBLNK( fName )
6a53f18a53 Patr*0123 CMM(
                0124       pIL = ILNBLNK( mdsioLocalDir )
                0125 CMM)
                0126 CMM(
                0127 C Assign special directory
                0128       if ( pIL.NE.0 ) then
                0129        write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
                0130       endif
                0131 CMM)
ffa487b126 Alis*0132
                0133 C Assign a free unit number as the I/O channel for this routine
                0134       call MDSFINDUNIT( dUnit, mythid )
                0135
eda676cb0f Patr*0136       if ( useSingleCPUIO ) then
                0137
                0138 #ifdef ALLOW_USE_MPI
b714306922 Jean*0139         IF( myProcId .EQ. 0 ) THEN
eda676cb0f Patr*0140 #else
                0141         IF ( .TRUE. ) THEN
                0142 #endif /* ALLOW_USE_MPI */
                0143
ffa487b126 Alis*0144 C Check first for global file with simple name (ie. fName)
eda676cb0f Patr*0145          dataFName = fName
                0146          inquire( file=dataFname, exist=exst )
                0147          if (exst) globalFile = .TRUE.
ffa487b126 Alis*0148
                0149 C If negative check for global file with MDS name (ie. fName.data)
eda676cb0f Patr*0150          if (.NOT. globalFile) then
47c8a35ff3 Jean*0151           write(dataFname,'(2a)') fName(1:IL),'.data'
eda676cb0f Patr*0152           inquire( file=dataFname, exist=exst )
                0153           if (exst) globalFile = .TRUE.
                0154          endif
                0155
                0156 C If global file is visible to process 0, then open it here.
                0157 C Otherwise stop program.
                0158          if ( globalFile) then
                0159           length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
                0160           open( dUnit, file=dataFName, status='old',
                0161      &         access='direct', recl=length_of_rec )
                0162          else
b714306922 Jean*0163           write(msgbuf,'(2a)')
47c8a35ff3 Jean*0164      &      ' MDSREADFIELD: filename: ',dataFName(1:IL)
eda676cb0f Patr*0165           call print_message( msgbuf, standardmessageunit,
                0166      &                        SQUEEZE_RIGHT , mythid)
                0167           call print_error( msgbuf, mythid )
                0168           write(msgbuf,'(a)')
                0169      &      ' MDSREADFIELD: File does not exist'
                0170           call print_message( msgbuf, standardmessageunit,
                0171      &                        SQUEEZE_RIGHT , mythid)
                0172           call print_error( msgbuf, mythid )
                0173           stop 'ABNORMAL END: S/R MDSREADFIELD'
                0174          endif
                0175
                0176         ENDIF
                0177
                0178 c-- useSingleCpuIO
                0179       else
                0180 C Only do I/O if I am the master thread
                0181
                0182 C Check first for global file with simple name (ie. fName)
                0183        dataFName = fName
ffa487b126 Alis*0184        inquire( file=dataFname, exist=exst )
                0185        if (exst) then
                0186         write(msgbuf,'(a,a)')
47c8a35ff3 Jean*0187      &    ' MDSREADFIELD: opening global file: ',dataFName(1:IL)
ffa487b126 Alis*0188         call print_message( msgbuf, standardmessageunit,
                0189      &                      SQUEEZE_RIGHT , mythid)
                0190        endif
eda676cb0f Patr*0191
                0192 C If negative check for global file with MDS name (ie. fName.data)
                0193        if (.NOT. globalFile) then
47c8a35ff3 Jean*0194         write(dataFname,'(2a)') fName(1:IL),'.data'
eda676cb0f Patr*0195         inquire( file=dataFname, exist=exst )
                0196         if (exst) then
                0197          write(msgbuf,'(a,a)')
47c8a35ff3 Jean*0198      &     ' MDSREADFIELD_GL: opening global file: ',dataFName(1:IL+5)
eda676cb0f Patr*0199          call print_message( msgbuf, standardmessageunit,
                0200      &                       SQUEEZE_RIGHT , mythid)
                0201          globalFile = .TRUE.
                0202         endif
                0203        endif
                0204
                0205 c-- useSingleCpuIO
ffa487b126 Alis*0206       endif
023d5a3a61 Patr*0207
eda676cb0f Patr*0208       if ( .not. useSingleCpuIO ) then
989416fbdf Patr*0209 cph      if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
eda676cb0f Patr*0210       if ( .not. ( globalFile ) ) then
023d5a3a61 Patr*0211
                0212 C If we are reading from a global file then we open it here
                0213       if (globalFile) then
                0214        length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
                0215        open( dUnit, file=dataFName, status='old',
                0216      &      access='direct', recl=length_of_rec )
                0217        fileIsOpen=.TRUE.
                0218       endif
                0219
b714306922 Jean*0220 C Loop over all processors
ffa487b126 Alis*0221       do jp=1,nPy
                0222       do ip=1,nPx
                0223 C Loop over all tiles
                0224       do bj=1,nSy
                0225       do bi=1,nSx
                0226 C If we are reading from a tiled MDS file then we open each one here
                0227         if (.NOT. globalFile) then
                0228          iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
                0229          jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
47c8a35ff3 Jean*0230          write(dataFname,'(2a,i3.3,a,i3.3,a)')
ffa487b126 Alis*0231      &              fName(1:IL),'.',iG,'.',jG,'.data'
                0232          inquire( file=dataFname, exist=exst )
                0233 C Of course, we only open the file if the tile is "active"
                0234 C (This is a place-holder for the active/passive mechanism
                0235          if (exst) then
ae605e558b Jean*0236           if ( debugLevel .GE. debLevB ) then
494ad43bae Patr*0237            write(msgbuf,'(a,a)')
47c8a35ff3 Jean*0238      &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
494ad43bae Patr*0239            call print_message( msgbuf, standardmessageunit,
ffa487b126 Alis*0240      &                        SQUEEZE_RIGHT , mythid)
494ad43bae Patr*0241           endif
ffa487b126 Alis*0242           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
                0243           open( dUnit, file=dataFName, status='old',
                0244      &        access='direct', recl=length_of_rec )
                0245           fileIsOpen=.TRUE.
                0246          else
                0247           fileIsOpen=.FALSE.
                0248           write(msgbuf,'(a,a)')
47c8a35ff3 Jean*0249      &      ' MDSREADFIELD_GL: filename: ',dataFName(1:IL+13)
ffa487b126 Alis*0250           call print_message( msgbuf, standardmessageunit,
                0251      &                        SQUEEZE_RIGHT , mythid)
48a21b9599 Patr*0252           call print_error( msgbuf, mythid )
ffa487b126 Alis*0253           write(msgbuf,'(a)')
                0254      &      ' MDSREADFIELD_GL: File does not exist'
48a21b9599 Patr*0255           call print_message( msgbuf, standardmessageunit,
                0256      &                        SQUEEZE_RIGHT , mythid)
ffa487b126 Alis*0257           call print_error( msgbuf, mythid )
                0258           stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                0259          endif
                0260         endif
                0261
                0262         if (fileIsOpen) then
5ae46f2adb Patr*0263          do k=1,Nr
ffa487b126 Alis*0264           do j=1,sNy
023d5a3a61 Patr*0265            if (globalFile) then
                0266             iG=bi+(ip-1)*nsx
                0267             jG=bj+(jp-1)*nsy
                0268             irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
                0269      &             + nSx*nPx*Ny*nNz*(irecord-1)
                0270            else
ffa487b126 Alis*0271             iG = 0
                0272             jG = 0
5ae46f2adb Patr*0273             irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
023d5a3a61 Patr*0274            endif
ffa487b126 Alis*0275            if (filePrec .eq. precFloat32) then
                0276             read(dUnit,rec=irec) r4seg
                0277 #ifdef _BYTESWAPIO
                0278             call MDS_BYTESWAPR4( sNx, r4seg )
                0279 #endif
                0280             if (arrType .eq. 'RS') then
b2fffc7e1a Jean*0281 #ifdef REAL4_IS_SLOW
5ae46f2adb Patr*0282              call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
b2fffc7e1a Jean*0283 #endif
ffa487b126 Alis*0284             elseif (arrType .eq. 'RL') then
5ae46f2adb Patr*0285              call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
ffa487b126 Alis*0286             else
                0287              write(msgbuf,'(a)')
                0288      &         ' MDSREADFIELD_GL: illegal value for arrType'
                0289              call print_error( msgbuf, mythid )
                0290              stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                0291             endif
                0292            elseif (filePrec .eq. precFloat64) then
                0293             read(dUnit,rec=irec) r8seg
                0294 #ifdef _BYTESWAPIO
                0295             call MDS_BYTESWAPR8( sNx, r8seg )
                0296 #endif
                0297             if (arrType .eq. 'RS') then
b2fffc7e1a Jean*0298 #ifdef REAL4_IS_SLOW
5ae46f2adb Patr*0299              call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
b2fffc7e1a Jean*0300 #endif
ffa487b126 Alis*0301             elseif (arrType .eq. 'RL') then
5ae46f2adb Patr*0302              call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
ffa487b126 Alis*0303             else
                0304              write(msgbuf,'(a)')
                0305      &         ' MDSREADFIELD_GL: illegal value for arrType'
                0306              call print_error( msgbuf, mythid )
                0307              stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                0308             endif
                0309            else
                0310             write(msgbuf,'(a)')
                0311      &        ' MDSREADFIELD_GL: illegal value for filePrec'
                0312             call print_error( msgbuf, mythid )
                0313             stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                0314            endif
                0315        do ii=1,sNx
                0316         arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
                0317        enddo
                0318
                0319 C End of j loop
                0320           enddo
                0321 C End of k loop
                0322          enddo
                0323          if (.NOT. globalFile) then
                0324           close( dUnit )
                0325           fileIsOpen = .FALSE.
                0326          endif
                0327         endif
                0328 C End of bi,bj loops
                0329        enddo
                0330       enddo
                0331 C End of ip,jp loops
                0332        enddo
                0333       enddo
                0334
                0335 C If global file was opened then close it
                0336       if (fileIsOpen .AND. globalFile) then
                0337        close( dUnit )
                0338        fileIsOpen = .FALSE.
                0339       endif
                0340
eda676cb0f Patr*0341 c      end of if ( .not. ( globalFile ) ) then
                0342       endif
                0343
989416fbdf Patr*0344 c      else of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
eda676cb0f Patr*0345       else
                0346
                0347        DO k=1,nNz
                0348
                0349 #ifdef ALLOW_USE_MPI
b714306922 Jean*0350          IF( myProcId .EQ. 0 ) THEN
eda676cb0f Patr*0351 #else
                0352          IF ( .TRUE. ) THEN
                0353 #endif /* ALLOW_USE_MPI */
                0354           irec = k+nNz*(irecord-1)
                0355           if (filePrec .eq. precFloat32) then
                0356            read(dUnit,rec=irec) xy_buffer_r4
                0357 #ifdef _BYTESWAPIO
                0358            call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
                0359 #endif
                0360            DO J=1,Ny
                0361             DO I=1,Nx
                0362              global(I,J) = xy_buffer_r4(I,J)
                0363             ENDDO
                0364            ENDDO
                0365           elseif (filePrec .eq. precFloat64) then
                0366            read(dUnit,rec=irec) xy_buffer_r8
                0367 #ifdef _BYTESWAPIO
                0368            call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
                0369 #endif
                0370            DO J=1,Ny
                0371             DO I=1,Nx
                0372              global(I,J) = xy_buffer_r8(I,J)
                0373             ENDDO
                0374            ENDDO
                0375           else
                0376            write(msgbuf,'(a)')
                0377      &            ' MDSREADFIELD: illegal value for filePrec'
                0378            call print_error( msgbuf, mythid )
                0379            stop 'ABNORMAL END: S/R MDSREADFIELD'
                0380           endif
                0381          ENDIF
                0382         DO jp=1,nPy
                0383          DO ip=1,nPx
                0384           DO bj = myByLo(myThid), myByHi(myThid)
                0385            DO bi = myBxLo(myThid), myBxHi(myThid)
                0386             DO J=1,sNy
                0387              JJ=((jp-1)*nSy+(bj-1))*sNy+J
                0388              DO I=1,sNx
                0389               II=((ip-1)*nSx+(bi-1))*sNx+I
                0390               arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
                0391              ENDDO
                0392             ENDDO
                0393            ENDDO
                0394           ENDDO
                0395          ENDDO
                0396         ENDDO
                0397
                0398        ENDDO
                0399 c      ENDDO k=1,nNz
                0400
                0401         close( dUnit )
                0402
023d5a3a61 Patr*0403       endif
                0404 c      end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
                0405
ffa487b126 Alis*0406       _END_MASTER( myThid )
                0407
b714306922 Jean*0408 #else /* ALLOW_CTRL */
                0409       STOP 'ABNORMAL END: S/R MDSREADFIELD_3D_GL is empty'
de7dc9fe18 Oliv*0410 #endif /* ALLOW_CTRL */
ffa487b126 Alis*0411 C     ------------------------------------------------------------------
b714306922 Jean*0412       RETURN
                0413       END
                0414
                0415 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
ffa487b126 Alis*0416
5ae46f2adb Patr*0417       SUBROUTINE MDSWRITEFIELD_3D_GL(
ffa487b126 Alis*0418      I   fName,
                0419      I   filePrec,
                0420      I   arrType,
                0421      I   nNz,
                0422      I   arr_gl,
                0423      I   irecord,
                0424      I   myIter,
                0425      I   myThid )
                0426 C
                0427 C Arguments:
                0428 C
eb5e2b9a92 Jean*0429 C fName     (string)  :: base name for file to write
                0430 C filePrec  (integer) :: number of bits per word in file (32 or 64)
                0431 C arrType   (char(2)) :: type of array "arr": either "RS" or "RL"
                0432 C nNz       (integer) :: size of third dimension: normally either 1 or Nr
                0433 C arr        (RS/RL)  :: array to write, arr(:,:,nNz,:,:)
                0434 C irecord   (integer) :: record number to write
                0435 C myIter    (integer) :: time step number
                0436 C myThid    (integer) :: thread identifier
ffa487b126 Alis*0437 C
                0438 C MDSWRITEFIELD creates either a file of the form "fName.data" and
                0439 C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
                0440 C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
                0441 C "fName.xxx.yyy.meta". A meta-file is always created.
                0442 C Currently, the meta-files are not read because it is difficult
                0443 C to parse files in fortran. We should read meta information before
                0444 C adding records to an existing multi-record file.
                0445 C The precision of the file is decsribed by filePrec, set either
                0446 C to floatPrec32 or floatPrec64. The precision or declaration of
                0447 C the array argument must be consistently described by the char*(2)
                0448 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
                0449 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
                0450 C nNz=Nr implies a 3-D model field. irecord is the record number
                0451 C to be read and must be >= 1. NOTE: It is currently assumed that
                0452 C the highest record number in the file was the last record written.
                0453 C Nor is there a consistency check between the routine arguments and file.
                0454 C ie. if your write record 2 after record 4 the meta information
                0455 C will record the number of records to be 2. This, again, is because
                0456 C we have read the meta information. To be fixed.
                0457 C
                0458 C Created: 03/16/99 adcroft@mit.edu
                0459 C
                0460 C Changed: 05/31/00 heimbach@mit.edu
                0461 C          open(dUnit, ..., status='old', ... -> status='unknown'
                0462
                0463       implicit none
                0464 C Global variables / common blocks
                0465 #include "SIZE.h"
                0466 #include "EEPARAMS.h"
                0467 #include "PARAMS.h"
                0468
                0469 C Routine arguments
                0470       character*(*) fName
                0471       integer filePrec
                0472       character*(2) arrType
                0473       integer nNz
                0474 cph(
                0475 cph      Real arr(*)
5ae46f2adb Patr*0476       _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
ffa487b126 Alis*0477 cph)
                0478       integer irecord
                0479       integer myIter
                0480       integer myThid
de7dc9fe18 Oliv*0481
                0482 #ifdef ALLOW_CTRL
                0483
ffa487b126 Alis*0484 C Functions
                0485       integer ILNBLNK
                0486       integer MDS_RECLEN
                0487 C Local variables
47c8a35ff3 Jean*0488       character*(MAX_LEN_FNAM) dataFName,metaFName
023d5a3a61 Patr*0489       integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
ffa487b126 Alis*0490       Real*4 r4seg(sNx)
                0491       Real*8 r8seg(sNx)
                0492       _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
b714306922 Jean*0493       INTEGER dimList(3,3), nDims, map2gl(2)
                0494       _RL dummyRL(1)
                0495       CHARACTER*8 blank8c
ffa487b126 Alis*0496       integer length_of_rec
                0497       logical fileIsOpen
                0498       character*(max_len_mbuf) msgbuf
023d5a3a61 Patr*0499 cph-usesingle(
47c8a35ff3 Jean*0500 #ifdef ALLOW_USE_MPI
023d5a3a61 Patr*0501       integer ii,jj
98ddeeaedb Jean*0502 c     integer iG_IO,jG_IO,npe
                0503       integer x_size,y_size
023d5a3a61 Patr*0504       PARAMETER ( x_size = Nx )
                0505       PARAMETER ( y_size = Ny )
                0506       Real*4 xy_buffer_r4(x_size,y_size)
                0507       Real*8 xy_buffer_r8(x_size,y_size)
                0508       Real*8 global(Nx,Ny)
47c8a35ff3 Jean*0509 #endif
023d5a3a61 Patr*0510 cph-usesingle)
6a53f18a53 Patr*0511 CMM(
                0512       integer pIL
                0513 CMM)
023d5a3a61 Patr*0514
b714306922 Jean*0515       DATA dummyRL(1) / 0. _d 0 /
                0516       DATA blank8c / '        ' /
                0517
ffa487b126 Alis*0518 C     ------------------------------------------------------------------
                0519
                0520 C Only do I/O if I am the master thread
                0521       _BEGIN_MASTER( myThid )
                0522
b2fffc7e1a Jean*0523 #ifndef REAL4_IS_SLOW
                0524       if (arrType .eq. 'RS') then
                0525        write(msgbuf,'(a)')
                0526      &   ' MDSWRITEFIELD_GL is wrong for arrType="RS" (=real*4)'
                0527        call print_error( msgbuf, mythid )
                0528        stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                0529       endif
                0530 #endif
                0531
ffa487b126 Alis*0532 C Record number must be >= 1
                0533       if (irecord .LT. 1) then
                0534        write(msgbuf,'(a,i9.8)')
                0535      &   ' MDSWRITEFIELD_GL: argument irecord = ',irecord
                0536        call print_message( msgbuf, standardmessageunit,
                0537      &                     SQUEEZE_RIGHT , mythid)
                0538        write(msgbuf,'(a)')
                0539      &   ' MDSWRITEFIELD_GL: invalid value for irecord'
                0540        call print_error( msgbuf, mythid )
                0541        stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                0542       endif
                0543
                0544 C Assume nothing
                0545       fileIsOpen=.FALSE.
                0546       IL=ILNBLNK( fName )
6a53f18a53 Patr*0547 CMM(
                0548       pIL = ILNBLNK( mdsioLocalDir )
                0549 CMM)
                0550 CMM(
                0551 C Assign special directory
                0552       if ( pIL.NE.0 ) then
                0553        write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
                0554       endif
                0555 CMM)
ffa487b126 Alis*0556
                0557 C Assign a free unit number as the I/O channel for this routine
                0558       call MDSFINDUNIT( dUnit, mythid )
                0559
023d5a3a61 Patr*0560 cph-usesingle(
                0561 #ifdef ALLOW_USE_MPI
                0562       _END_MASTER( myThid )
                0563 C If option globalFile is desired but does not work or if
                0564 C globalFile is too slow, then try using single-CPU I/O.
                0565       if (useSingleCpuIO) then
                0566
                0567 C Master thread of process 0, only, opens a global file
                0568        _BEGIN_MASTER( myThid )
b714306922 Jean*0569         IF( myProcId .EQ. 0 ) THEN
47c8a35ff3 Jean*0570          write(dataFname,'(2a)') fName(1:IL),'.data'
023d5a3a61 Patr*0571          length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
                0572          if (irecord .EQ. 1) then
                0573           open( dUnit, file=dataFName, status=_NEW_STATUS,
                0574      &        access='direct', recl=length_of_rec )
                0575          else
                0576           open( dUnit, file=dataFName, status=_OLD_STATUS,
                0577      &        access='direct', recl=length_of_rec )
                0578          endif
                0579         ENDIF
                0580        _END_MASTER( myThid )
                0581
                0582 C Gather array and write it to file, one vertical level at a time
                0583        DO k=1,nNz
b714306922 Jean*0584 C Loop over all processors
023d5a3a61 Patr*0585         do jp=1,nPy
                0586         do ip=1,nPx
                0587         DO bj = myByLo(myThid), myByHi(myThid)
                0588          DO bi = myBxLo(myThid), myBxHi(myThid)
                0589           DO J=1,sNy
                0590            JJ=((jp-1)*nSy+(bj-1))*sNy+J
                0591            DO I=1,sNx
                0592             II=((ip-1)*nSx+(bi-1))*sNx+I
                0593             global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
                0594            ENDDO
                0595           ENDDO
                0596          ENDDO
                0597         ENDDO
                0598         enddo
                0599         enddo
                0600         _BEGIN_MASTER( myThid )
b714306922 Jean*0601          IF( myProcId .EQ. 0 ) THEN
023d5a3a61 Patr*0602           irec=k+nNz*(irecord-1)
                0603           if (filePrec .eq. precFloat32) then
                0604            DO J=1,Ny
                0605             DO I=1,Nx
                0606              xy_buffer_r4(I,J) = global(I,J)
                0607             ENDDO
                0608            ENDDO
                0609 #ifdef _BYTESWAPIO
                0610            call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
                0611 #endif
                0612            write(dUnit,rec=irec) xy_buffer_r4
                0613           elseif (filePrec .eq. precFloat64) then
                0614            DO J=1,Ny
                0615             DO I=1,Nx
                0616              xy_buffer_r8(I,J) = global(I,J)
                0617             ENDDO
                0618            ENDDO
                0619 #ifdef _BYTESWAPIO
                0620            call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
                0621 #endif
                0622            write(dUnit,rec=irec) xy_buffer_r8
                0623           else
                0624            write(msgbuf,'(a)')
                0625      &       ' MDSWRITEFIELD: illegal value for filePrec'
                0626            call print_error( msgbuf, mythid )
                0627            stop 'ABNORMAL END: S/R MDSWRITEFIELD'
                0628           endif
                0629          ENDIF
                0630         _END_MASTER( myThid )
                0631        ENDDO
                0632
                0633 C Close data-file and create meta-file
                0634        _BEGIN_MASTER( myThid )
b714306922 Jean*0635         IF( myProcId .EQ. 0 ) THEN
023d5a3a61 Patr*0636          close( dUnit )
47c8a35ff3 Jean*0637          write(metaFName,'(2a)') fName(1:IL),'.meta'
023d5a3a61 Patr*0638          dimList(1,1)=Nx
                0639          dimList(2,1)=1
                0640          dimList(3,1)=Nx
                0641          dimList(1,2)=Ny
                0642          dimList(2,2)=1
                0643          dimList(3,2)=Ny
                0644          dimList(1,3)=nNz
                0645          dimList(2,3)=1
                0646          dimList(3,3)=nNz
b714306922 Jean*0647          nDims=3
                0648          if (nNz .EQ. 1) nDims=2
                0649          map2gl(1) = 0
                0650          map2gl(2) = 1
                0651          CALL MDS_WRITE_META(
                0652      I              metaFName, dataFName, the_run_name, ' ',
                0653      I              filePrec, nDims, dimList, map2gl, 0, blank8c,
a50692f9cd Jean*0654      I              0, dummyRL, oneRL, irecord, myIter, myThid )
023d5a3a61 Patr*0655         ENDIF
                0656        _END_MASTER( myThid )
                0657 C To be safe, make other processes wait for I/O completion
                0658        _BARRIER
                0659
                0660       elseif ( .NOT. useSingleCpuIO ) then
                0661       _BEGIN_MASTER( myThid )
                0662 #endif /* ALLOW_USE_MPI */
                0663 cph-usesingle)
ffa487b126 Alis*0664
b714306922 Jean*0665 C Loop over all processors
ffa487b126 Alis*0666       do jp=1,nPy
                0667       do ip=1,nPx
                0668 C Loop over all tiles
                0669       do bj=1,nSy
                0670        do bi=1,nSx
                0671 C If we are writing to a tiled MDS file then we open each one here
                0672          iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
                0673          jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
47c8a35ff3 Jean*0674          write(dataFname,'(2a,i3.3,a,i3.3,a)')
ffa487b126 Alis*0675      &              fName(1:IL),'.',iG,'.',jG,'.data'
                0676          if (irecord .EQ. 1) then
                0677           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
                0678           open( dUnit, file=dataFName, status=_NEW_STATUS,
                0679      &       access='direct', recl=length_of_rec )
                0680           fileIsOpen=.TRUE.
                0681          else
                0682           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
                0683           open( dUnit, file=dataFName, status=_OLD_STATUS,
                0684      &       access='direct', recl=length_of_rec )
                0685           fileIsOpen=.TRUE.
                0686          endif
                0687         if (fileIsOpen) then
5ae46f2adb Patr*0688          do k=1,Nr
ffa487b126 Alis*0689           do j=1,sNy
47c8a35ff3 Jean*0690              do i=1,sNx
                0691                 arr(i,j,k,bi,bj)=arr_gl(i,bi,ip,j,bj,jp,k)
ffa487b126 Alis*0692              enddo
                0693             iG = 0
                0694             jG = 0
5ae46f2adb Patr*0695             irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
ffa487b126 Alis*0696            if (filePrec .eq. precFloat32) then
                0697             if (arrType .eq. 'RS') then
b2fffc7e1a Jean*0698 #ifdef REAL4_IS_SLOW
5ae46f2adb Patr*0699              call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
b2fffc7e1a Jean*0700 #endif
ffa487b126 Alis*0701             elseif (arrType .eq. 'RL') then
5ae46f2adb Patr*0702              call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
ffa487b126 Alis*0703             else
                0704              write(msgbuf,'(a)')
                0705      &         ' MDSWRITEFIELD_GL: illegal value for arrType'
                0706              call print_error( msgbuf, mythid )
                0707              stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                0708             endif
                0709 #ifdef _BYTESWAPIO
                0710             call MDS_BYTESWAPR4( sNx, r4seg )
                0711 #endif
                0712             write(dUnit,rec=irec) r4seg
                0713            elseif (filePrec .eq. precFloat64) then
                0714             if (arrType .eq. 'RS') then
b2fffc7e1a Jean*0715 #ifdef REAL4_IS_SLOW
5ae46f2adb Patr*0716              call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
b2fffc7e1a Jean*0717 #endif
ffa487b126 Alis*0718             elseif (arrType .eq. 'RL') then
5ae46f2adb Patr*0719              call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
ffa487b126 Alis*0720             else
                0721              write(msgbuf,'(a)')
                0722      &         ' MDSWRITEFIELD_GL: illegal value for arrType'
                0723              call print_error( msgbuf, mythid )
                0724              stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                0725             endif
                0726 #ifdef _BYTESWAPIO
                0727             call MDS_BYTESWAPR8( sNx, r8seg )
                0728 #endif
                0729             write(dUnit,rec=irec) r8seg
                0730            else
                0731             write(msgbuf,'(a)')
                0732      &        ' MDSWRITEFIELD_GL: illegal value for filePrec'
                0733             call print_error( msgbuf, mythid )
                0734             stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                0735            endif
                0736 C End of j loop
                0737           enddo
                0738 C End of k loop
                0739          enddo
                0740         else
                0741          write(msgbuf,'(a)')
                0742      &     ' MDSWRITEFIELD_GL: I should never get to this point'
                0743          call print_error( msgbuf, mythid )
                0744          stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                0745         endif
                0746 C If we were writing to a tiled MDS file then we close it here
                0747         if (fileIsOpen) then
                0748          close( dUnit )
                0749          fileIsOpen = .FALSE.
                0750         endif
                0751 C Create meta-file for each tile if we are tiling
                0752          iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
                0753          jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
47c8a35ff3 Jean*0754          write(metaFname,'(2a,i3.3,a,i3.3,a)')
ffa487b126 Alis*0755      &              fName(1:IL),'.',iG,'.',jG,'.meta'
                0756          dimList(1,1)=Nx
                0757          dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
                0758          dimList(3,1)=((ip-1)*nSx+bi)*sNx
                0759          dimList(1,2)=Ny
                0760          dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
                0761          dimList(3,2)=((jp-1)*nSy+bj)*sNy
                0762          dimList(1,3)=Nr
                0763          dimList(2,3)=1
                0764          dimList(3,3)=Nr
b714306922 Jean*0765          nDims=3
                0766          if (Nr .EQ. 1) nDims=2
                0767          map2gl(1) = 0
                0768          map2gl(2) = 1
                0769          CALL MDS_WRITE_META(
                0770      I              metaFName, dataFName, the_run_name, ' ',
                0771      I              filePrec, nDims, dimList, map2gl, 0, blank8c,
a50692f9cd Jean*0772      I              0, dummyRL, oneRL, irecord, myIter, myThid )
ffa487b126 Alis*0773 C End of bi,bj loops
                0774        enddo
                0775       enddo
                0776 C End of ip,jp loops
                0777        enddo
                0778       enddo
                0779
                0780       _END_MASTER( myThid )
                0781
023d5a3a61 Patr*0782 cph-usesingle(
                0783 #ifdef ALLOW_USE_MPI
                0784 C endif useSingleCpuIO
                0785       endif
                0786 #endif /* ALLOW_USE_MPI */
                0787 cph-usesingle)
                0788
b714306922 Jean*0789 #else /* ALLOW_CTRL */
                0790       STOP 'ABNORMAL END: S/R MDSWRITEFIELD_3D_GL is empty'
de7dc9fe18 Oliv*0791 #endif /* ALLOW_CTRL */
5ae46f2adb Patr*0792 C     ------------------------------------------------------------------
b714306922 Jean*0793       RETURN
                0794       END
                0795
                0796 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
5ae46f2adb Patr*0797
                0798       SUBROUTINE MDSREADFIELD_2D_GL(
                0799      I   fName,
                0800      I   filePrec,
                0801      I   arrType,
                0802      I   nNz,
                0803      O   arr_gl,
                0804      I   irecord,
                0805      I   myThid )
                0806 C
                0807 C Arguments:
                0808 C
eb5e2b9a92 Jean*0809 C fName     (string)  :: base name for file to read
                0810 C filePrec  (integer) :: number of bits per word in file (32 or 64)
                0811 C arrType   (char(2)) :: type of array "arr": either "RS" or "RL"
                0812 C nNz       (integer) :: size of third dimension: normally either 1 or Nr
                0813 C arr        (RS/RL)  :: array to read into, arr(:,:,nNz,:,:)
                0814 C irecord   (integer) :: record number to read
                0815 C myThid    (integer) :: thread identifier
5ae46f2adb Patr*0816 C
                0817 C MDSREADFIELD first checks to see if the file "fName" exists, then
                0818 C if the file "fName.data" exists and finally the tiled files of the
                0819 C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
                0820 C read because it is difficult to parse files in fortran.
                0821 C The precision of the file is decsribed by filePrec, set either
                0822 C to floatPrec32 or floatPrec64. The precision or declaration of
                0823 C the array argument must be consistently described by the char*(2)
                0824 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
                0825 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
                0826 C nNz=Nr implies a 3-D model field. irecord is the record number
                0827 C to be read and must be >= 1. The file data is stored in
                0828 C arr *but* the overlaps are *not* updated. ie. An exchange must
                0829 C be called. This is because the routine is sometimes called from
                0830 C within a MASTER_THID region.
                0831 C
                0832 C Created: 03/16/99 adcroft@mit.edu
                0833
                0834       implicit none
                0835 C Global variables / common blocks
                0836 #include "SIZE.h"
                0837 #include "EEPARAMS.h"
                0838 #include "PARAMS.h"
                0839
                0840 C Routine arguments
                0841       character*(*) fName
                0842       integer filePrec
                0843       character*(2) arrType
                0844       integer nNz, nLocz
                0845       parameter (nLocz = 1)
                0846       _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
                0847       integer irecord
                0848       integer myThid
de7dc9fe18 Oliv*0849
                0850 #ifdef ALLOW_CTRL
                0851
5ae46f2adb Patr*0852 C Functions
                0853       integer ILNBLNK
                0854       integer MDS_RECLEN
                0855 C Local variables
47c8a35ff3 Jean*0856       character*(MAX_LEN_FNAM) dataFName
7ac755d99f Patr*0857       integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
5ae46f2adb Patr*0858       logical exst
                0859       _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
                0860       Real*4 r4seg(sNx)
                0861       Real*8 r8seg(sNx)
                0862       logical globalFile,fileIsOpen
                0863       integer length_of_rec
                0864       character*(max_len_mbuf) msgbuf
eda676cb0f Patr*0865 cph-usesingle(
                0866       integer ii,jj
47c8a35ff3 Jean*0867 c     integer iG_IO,jG_IO,npe
                0868       integer x_size,y_size
eda676cb0f Patr*0869       PARAMETER ( x_size = Nx )
                0870       PARAMETER ( y_size = Ny )
                0871       Real*4 xy_buffer_r4(x_size,y_size)
                0872       Real*8 xy_buffer_r8(x_size,y_size)
                0873       Real*8 global(Nx,Ny)
47c8a35ff3 Jean*0874 c     _RL    local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
eda676cb0f Patr*0875 cph-usesingle)
6a53f18a53 Patr*0876 CMM(
                0877       integer pIL
                0878 CMM)
eda676cb0f Patr*0879
5ae46f2adb Patr*0880 C     ------------------------------------------------------------------
                0881
                0882 C Only do I/O if I am the master thread
                0883       _BEGIN_MASTER( myThid )
                0884
b2fffc7e1a Jean*0885 #ifndef REAL4_IS_SLOW
                0886       if (arrType .eq. 'RS') then
                0887        write(msgbuf,'(a)')
                0888      &   ' MDSREADFIELD_GL is wrong for arrType="RS" (=real*4)'
                0889        call print_error( msgbuf, mythid )
                0890        stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                0891       endif
                0892 #endif
                0893
5ae46f2adb Patr*0894 C Record number must be >= 1
                0895       if (irecord .LT. 1) then
                0896        write(msgbuf,'(a,i9.8)')
                0897      &   ' MDSREADFIELD_GL: argument irecord = ',irecord
                0898        call print_message( msgbuf, standardmessageunit,
                0899      &                     SQUEEZE_RIGHT , mythid)
                0900        write(msgbuf,'(a)')
                0901      &   ' MDSREADFIELD_GL: Invalid value for irecord'
                0902        call print_error( msgbuf, mythid )
                0903        stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                0904       endif
                0905
                0906 C Assume nothing
                0907       globalFile = .FALSE.
                0908       fileIsOpen = .FALSE.
                0909       IL=ILNBLNK( fName )
6a53f18a53 Patr*0910 CMM(
                0911       pIL = ILNBLNK( mdsioLocalDir )
                0912 CMM)
                0913 CMM(
                0914 C Assign special directory
                0915       if ( pIL.NE.0 ) then
                0916        write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
                0917       endif
                0918 CMM)
5ae46f2adb Patr*0919
                0920 C Assign a free unit number as the I/O channel for this routine
                0921       call MDSFINDUNIT( dUnit, mythid )
                0922
eda676cb0f Patr*0923       if ( useSingleCPUIO ) then
                0924
                0925 C master thread of process 0, only, opens a global file
                0926 #ifdef ALLOW_USE_MPI
b714306922 Jean*0927         IF( myProcId .EQ. 0 ) THEN
eda676cb0f Patr*0928 #else
                0929         IF ( .TRUE. ) THEN
                0930 #endif /* ALLOW_USE_MPI */
                0931
5ae46f2adb Patr*0932 C Check first for global file with simple name (ie. fName)
eda676cb0f Patr*0933          dataFName = fName
                0934          inquire( file=dataFname, exist=exst )
                0935          if (exst) globalFile = .TRUE.
5ae46f2adb Patr*0936
                0937 C If negative check for global file with MDS name (ie. fName.data)
eda676cb0f Patr*0938          if (.NOT. globalFile) then
47c8a35ff3 Jean*0939           write(dataFname,'(2a)') fName(1:IL),'.data'
eda676cb0f Patr*0940           inquire( file=dataFname, exist=exst )
                0941           if (exst) globalFile = .TRUE.
                0942          endif
                0943
                0944 C If global file is visible to process 0, then open it here.
                0945 C Otherwise stop program.
                0946          if ( globalFile) then
                0947           length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
                0948           open( dUnit, file=dataFName, status='old',
                0949      &         access='direct', recl=length_of_rec )
                0950          else
b714306922 Jean*0951           write(msgbuf,'(2a)')
47c8a35ff3 Jean*0952      &      ' MDSREADFIELD: filename: ',dataFName(1:IL)
eda676cb0f Patr*0953           call print_message( msgbuf, standardmessageunit,
                0954      &                        SQUEEZE_RIGHT , mythid)
                0955           call print_error( msgbuf, mythid )
                0956           write(msgbuf,'(a)')
                0957      &      ' MDSREADFIELD: File does not exist'
                0958           call print_message( msgbuf, standardmessageunit,
                0959      &                        SQUEEZE_RIGHT , mythid)
                0960           call print_error( msgbuf, mythid )
                0961           stop 'ABNORMAL END: S/R MDSREADFIELD'
                0962          endif
                0963
                0964         ENDIF
                0965
                0966 c-- useSingleCpuIO
                0967       else
                0968
                0969 C Check first for global file with simple name (ie. fName)
                0970        dataFName = fName
5ae46f2adb Patr*0971        inquire( file=dataFname, exist=exst )
                0972        if (exst) then
                0973         write(msgbuf,'(a,a)')
47c8a35ff3 Jean*0974      &    ' MDSREADFIELD: opening global file: ',dataFName(1:IL)
5ae46f2adb Patr*0975         call print_message( msgbuf, standardmessageunit,
                0976      &                      SQUEEZE_RIGHT , mythid)
                0977        endif
eda676cb0f Patr*0978
                0979 C If negative check for global file with MDS name (ie. fName.data)
                0980        if (.NOT. globalFile) then
47c8a35ff3 Jean*0981         write(dataFname,'(2a)') fName(1:IL),'.data'
eda676cb0f Patr*0982         inquire( file=dataFname, exist=exst )
                0983         if (exst) then
                0984          write(msgbuf,'(a,a)')
47c8a35ff3 Jean*0985      &     ' MDSREADFIELD_GL: opening global file: ',dataFName(1:IL+5)
eda676cb0f Patr*0986          call print_message( msgbuf, standardmessageunit,
                0987      &                       SQUEEZE_RIGHT , mythid)
                0988          globalFile = .TRUE.
                0989         endif
                0990        endif
                0991
                0992 c-- useSingleCpuIO
5ae46f2adb Patr*0993       endif
023d5a3a61 Patr*0994
eda676cb0f Patr*0995       if ( .not. useSingleCpuIO ) then
                0996 cph      if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
                0997       if ( .not. ( globalFile ) ) then
023d5a3a61 Patr*0998
                0999 C If we are reading from a global file then we open it here
                1000       if (globalFile) then
                1001        length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
                1002        open( dUnit, file=dataFName, status='old',
                1003      &      access='direct', recl=length_of_rec )
                1004        fileIsOpen=.TRUE.
                1005       endif
                1006
b714306922 Jean*1007 C Loop over all processors
5ae46f2adb Patr*1008       do jp=1,nPy
                1009       do ip=1,nPx
                1010 C Loop over all tiles
                1011       do bj=1,nSy
                1012       do bi=1,nSx
                1013 C If we are reading from a tiled MDS file then we open each one here
                1014         if (.NOT. globalFile) then
                1015          iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
                1016          jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
47c8a35ff3 Jean*1017          write(dataFname,'(2a,i3.3,a,i3.3,a)')
5ae46f2adb Patr*1018      &              fName(1:IL),'.',iG,'.',jG,'.data'
                1019          inquire( file=dataFname, exist=exst )
                1020 C Of course, we only open the file if the tile is "active"
                1021 C (This is a place-holder for the active/passive mechanism
                1022          if (exst) then
ae605e558b Jean*1023           if ( debugLevel .GE. debLevB ) then
494ad43bae Patr*1024            write(msgbuf,'(a,a)')
47c8a35ff3 Jean*1025      &      ' MDSREADFIELD_GL: opening file: ',dataFName(1:IL+13)
494ad43bae Patr*1026            call print_message( msgbuf, standardmessageunit,
5ae46f2adb Patr*1027      &                        SQUEEZE_RIGHT , mythid)
494ad43bae Patr*1028           endif
5ae46f2adb Patr*1029           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
                1030           open( dUnit, file=dataFName, status='old',
                1031      &        access='direct', recl=length_of_rec )
                1032           fileIsOpen=.TRUE.
                1033          else
                1034           fileIsOpen=.FALSE.
                1035           write(msgbuf,'(a,a)')
47c8a35ff3 Jean*1036      &      ' MDSREADFIELD_GL: filename: ',dataFName(1:IL+13)
5ae46f2adb Patr*1037           call print_message( msgbuf, standardmessageunit,
                1038      &                        SQUEEZE_RIGHT , mythid)
48a21b9599 Patr*1039           call print_error( msgbuf, mythid )
5ae46f2adb Patr*1040           write(msgbuf,'(a)')
                1041      &      ' MDSREADFIELD_GL: File does not exist'
48a21b9599 Patr*1042           call print_message( msgbuf, standardmessageunit,
                1043      &                        SQUEEZE_RIGHT , mythid)
5ae46f2adb Patr*1044           call print_error( msgbuf, mythid )
                1045           stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                1046          endif
                1047         endif
                1048
                1049         if (fileIsOpen) then
                1050          do k=1,nLocz
                1051           do j=1,sNy
023d5a3a61 Patr*1052            if (globalFile) then
                1053             iG=bi+(ip-1)*nsx
                1054             jG=bj+(jp-1)*nsy
                1055             irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
                1056      &             + nSx*nPx*Ny*nLocz*(irecord-1)
                1057            else
5ae46f2adb Patr*1058             iG = 0
                1059             jG = 0
                1060             irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
023d5a3a61 Patr*1061            endif
5ae46f2adb Patr*1062            if (filePrec .eq. precFloat32) then
                1063             read(dUnit,rec=irec) r4seg
                1064 #ifdef _BYTESWAPIO
                1065             call MDS_BYTESWAPR4( sNx, r4seg )
ffa487b126 Alis*1066 #endif
5ae46f2adb Patr*1067             if (arrType .eq. 'RS') then
b2fffc7e1a Jean*1068 #ifdef REAL4_IS_SLOW
5ae46f2adb Patr*1069              call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
b2fffc7e1a Jean*1070 #endif
5ae46f2adb Patr*1071             elseif (arrType .eq. 'RL') then
                1072              call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
                1073             else
                1074              write(msgbuf,'(a)')
                1075      &         ' MDSREADFIELD_GL: illegal value for arrType'
                1076              call print_error( msgbuf, mythid )
                1077              stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                1078             endif
                1079            elseif (filePrec .eq. precFloat64) then
                1080             read(dUnit,rec=irec) r8seg
                1081 #ifdef _BYTESWAPIO
                1082             call MDS_BYTESWAPR8( sNx, r8seg )
                1083 #endif
                1084             if (arrType .eq. 'RS') then
b2fffc7e1a Jean*1085 #ifdef REAL4_IS_SLOW
5ae46f2adb Patr*1086              call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
b2fffc7e1a Jean*1087 #endif
5ae46f2adb Patr*1088             elseif (arrType .eq. 'RL') then
                1089              call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
                1090             else
                1091              write(msgbuf,'(a)')
                1092      &         ' MDSREADFIELD_GL: illegal value for arrType'
                1093              call print_error( msgbuf, mythid )
                1094              stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                1095             endif
                1096            else
                1097             write(msgbuf,'(a)')
                1098      &        ' MDSREADFIELD_GL: illegal value for filePrec'
                1099             call print_error( msgbuf, mythid )
                1100             stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
                1101            endif
                1102        do ii=1,sNx
                1103         arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
                1104        enddo
                1105
                1106 C End of j loop
                1107           enddo
                1108 C End of k loop
                1109          enddo
                1110          if (.NOT. globalFile) then
                1111           close( dUnit )
                1112           fileIsOpen = .FALSE.
                1113          endif
                1114         endif
                1115 C End of bi,bj loops
                1116        enddo
                1117       enddo
                1118 C End of ip,jp loops
                1119        enddo
                1120       enddo
                1121
                1122 C If global file was opened then close it
                1123       if (fileIsOpen .AND. globalFile) then
                1124        close( dUnit )
                1125        fileIsOpen = .FALSE.
                1126       endif
                1127
eda676cb0f Patr*1128 c      end of if ( .not. ( globalFile ) ) then
                1129       endif
                1130
                1131 c      else of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
                1132       else
                1133
                1134        DO k=1,nLocz
                1135
                1136 #ifdef ALLOW_USE_MPI
b714306922 Jean*1137          IF( myProcId .EQ. 0 ) THEN
eda676cb0f Patr*1138 #else
                1139          IF ( .TRUE. ) THEN
                1140 #endif /* ALLOW_USE_MPI */
                1141           irec = k+nNz*(irecord-1)
                1142           if (filePrec .eq. precFloat32) then
                1143            read(dUnit,rec=irec) xy_buffer_r4
                1144 #ifdef _BYTESWAPIO
                1145            call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
                1146 #endif
                1147            DO J=1,Ny
                1148             DO I=1,Nx
                1149              global(I,J) = xy_buffer_r4(I,J)
                1150             ENDDO
                1151            ENDDO
                1152           elseif (filePrec .eq. precFloat64) then
                1153            read(dUnit,rec=irec) xy_buffer_r8
                1154 #ifdef _BYTESWAPIO
                1155            call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
                1156 #endif
                1157            DO J=1,Ny
                1158             DO I=1,Nx
                1159              global(I,J) = xy_buffer_r8(I,J)
                1160             ENDDO
                1161            ENDDO
                1162           else
                1163            write(msgbuf,'(a)')
                1164      &            ' MDSREADFIELD: illegal value for filePrec'
                1165            call print_error( msgbuf, mythid )
                1166            stop 'ABNORMAL END: S/R MDSREADFIELD'
                1167           endif
                1168          ENDIF
                1169         DO jp=1,nPy
                1170          DO ip=1,nPx
                1171           DO bj = myByLo(myThid), myByHi(myThid)
                1172            DO bi = myBxLo(myThid), myBxHi(myThid)
                1173             DO J=1,sNy
                1174              JJ=((jp-1)*nSy+(bj-1))*sNy+J
                1175              DO I=1,sNx
                1176               II=((ip-1)*nSx+(bi-1))*sNx+I
                1177               arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
                1178              ENDDO
                1179             ENDDO
                1180            ENDDO
                1181           ENDDO
                1182          ENDDO
                1183         ENDDO
                1184
                1185        ENDDO
                1186 c      ENDDO k=1,nNz
                1187
                1188         close( dUnit )
                1189
023d5a3a61 Patr*1190       endif
                1191 c      end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
                1192
5ae46f2adb Patr*1193       _END_MASTER( myThid )
                1194
b714306922 Jean*1195 #else /* ALLOW_CTRL */
                1196       STOP 'ABNORMAL END: S/R MDSREADFIELD_2D_GL is empty'
de7dc9fe18 Oliv*1197 #endif /* ALLOW_CTRL */
5ae46f2adb Patr*1198 C     ------------------------------------------------------------------
b714306922 Jean*1199       RETURN
                1200       END
                1201
                1202 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
5ae46f2adb Patr*1203
                1204       SUBROUTINE MDSWRITEFIELD_2D_GL(
                1205      I   fName,
                1206      I   filePrec,
                1207      I   arrType,
                1208      I   nNz,
                1209      I   arr_gl,
                1210      I   irecord,
                1211      I   myIter,
                1212      I   myThid )
                1213 C
                1214 C Arguments:
                1215 C
eb5e2b9a92 Jean*1216 C fName     (string)  :: base name for file to write
                1217 C filePrec  (integer) :: number of bits per word in file (32 or 64)
                1218 C arrType   (char(2)) :: type of array "arr": either "RS" or "RL"
                1219 C nNz       (integer) :: size of third dimension: normally either 1 or Nr
                1220 C arr        (RS/RL)  :: array to write, arr(:,:,nNz,:,:)
                1221 C irecord   (integer) :: record number to write
                1222 C myIter    (integer) :: time step number
                1223 C myThid    (integer) :: thread identifier
5ae46f2adb Patr*1224 C
                1225 C MDSWRITEFIELD creates either a file of the form "fName.data" and
                1226 C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
                1227 C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
                1228 C "fName.xxx.yyy.meta". A meta-file is always created.
                1229 C Currently, the meta-files are not read because it is difficult
                1230 C to parse files in fortran. We should read meta information before
                1231 C adding records to an existing multi-record file.
                1232 C The precision of the file is decsribed by filePrec, set either
                1233 C to floatPrec32 or floatPrec64. The precision or declaration of
                1234 C the array argument must be consistently described by the char*(2)
                1235 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
                1236 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
                1237 C nNz=Nr implies a 3-D model field. irecord is the record number
                1238 C to be read and must be >= 1. NOTE: It is currently assumed that
                1239 C the highest record number in the file was the last record written.
                1240 C Nor is there a consistency check between the routine arguments and file.
                1241 C ie. if your write record 2 after record 4 the meta information
                1242 C will record the number of records to be 2. This, again, is because
                1243 C we have read the meta information. To be fixed.
                1244 C
                1245 C Created: 03/16/99 adcroft@mit.edu
                1246 C
                1247 C Changed: 05/31/00 heimbach@mit.edu
                1248 C          open(dUnit, ..., status='old', ... -> status='unknown'
                1249
                1250       implicit none
                1251 C Global variables / common blocks
                1252 #include "SIZE.h"
                1253 #include "EEPARAMS.h"
                1254 #include "PARAMS.h"
                1255
                1256 C Routine arguments
                1257       character*(*) fName
                1258       integer filePrec
                1259       character*(2) arrType
                1260       integer nNz, nLocz
                1261       parameter (nLocz = 1)
                1262 cph(
                1263 cph      Real arr(*)
                1264       _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
                1265 cph)
                1266       integer irecord
                1267       integer myIter
                1268       integer myThid
de7dc9fe18 Oliv*1269
                1270 #ifdef ALLOW_CTRL
                1271
5ae46f2adb Patr*1272 C Functions
                1273       integer ILNBLNK
                1274       integer MDS_RECLEN
                1275 C Local variables
47c8a35ff3 Jean*1276       character*(MAX_LEN_FNAM) dataFName,metaFName
023d5a3a61 Patr*1277       integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
5ae46f2adb Patr*1278       Real*4 r4seg(sNx)
                1279       Real*8 r8seg(sNx)
                1280       _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
b714306922 Jean*1281       INTEGER dimList(3,3), nDims, map2gl(2)
                1282       _RL dummyRL(1)
                1283       CHARACTER*8 blank8c
5ae46f2adb Patr*1284       integer length_of_rec
                1285       logical fileIsOpen
                1286       character*(max_len_mbuf) msgbuf
023d5a3a61 Patr*1287 cph-usesingle(
47c8a35ff3 Jean*1288 #ifdef ALLOW_USE_MPI
023d5a3a61 Patr*1289       integer ii,jj
98ddeeaedb Jean*1290 c     integer iG_IO,jG_IO,npe
                1291       integer x_size,y_size
023d5a3a61 Patr*1292       PARAMETER ( x_size = Nx )
                1293       PARAMETER ( y_size = Ny )
                1294       Real*4 xy_buffer_r4(x_size,y_size)
                1295       Real*8 xy_buffer_r8(x_size,y_size)
                1296       Real*8 global(Nx,Ny)
47c8a35ff3 Jean*1297 #endif
023d5a3a61 Patr*1298 cph-usesingle)
6a53f18a53 Patr*1299 CMM(
                1300       integer pIL
                1301 CMM)
023d5a3a61 Patr*1302
b714306922 Jean*1303       DATA dummyRL(1) / 0. _d 0 /
                1304       DATA blank8c / '        ' /
                1305
5ae46f2adb Patr*1306 C     ------------------------------------------------------------------
                1307
                1308 C Only do I/O if I am the master thread
                1309       _BEGIN_MASTER( myThid )
                1310
b2fffc7e1a Jean*1311 #ifndef REAL4_IS_SLOW
                1312       if (arrType .eq. 'RS') then
                1313        write(msgbuf,'(a)')
                1314      &   ' MDSWRITEFIELD_GL is wrong for arrType="RS" (=real*4)'
                1315        call print_error( msgbuf, mythid )
                1316        stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                1317       endif
                1318 #endif
                1319
5ae46f2adb Patr*1320 C Record number must be >= 1
                1321       if (irecord .LT. 1) then
                1322        write(msgbuf,'(a,i9.8)')
                1323      &   ' MDSWRITEFIELD_GL: argument irecord = ',irecord
                1324        call print_message( msgbuf, standardmessageunit,
                1325      &                     SQUEEZE_RIGHT , mythid)
                1326        write(msgbuf,'(a)')
                1327      &   ' MDSWRITEFIELD_GL: invalid value for irecord'
                1328        call print_error( msgbuf, mythid )
                1329        stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                1330       endif
                1331
                1332 C Assume nothing
                1333       fileIsOpen=.FALSE.
                1334       IL=ILNBLNK( fName )
6a53f18a53 Patr*1335 CMM(
                1336       pIL = ILNBLNK( mdsioLocalDir )
                1337 CMM)
                1338 CMM(
                1339 C Assign special directory
                1340       if ( pIL.NE.0 ) then
                1341        write(fName,'(2a)') mdsioLocalDir(1:pIL), fName(1:IL)
                1342       endif
                1343 CMM)
5ae46f2adb Patr*1344
                1345 C Assign a free unit number as the I/O channel for this routine
                1346       call MDSFINDUNIT( dUnit, mythid )
                1347
                1348
023d5a3a61 Patr*1349 cph-usesingle(
                1350 #ifdef ALLOW_USE_MPI
                1351       _END_MASTER( myThid )
                1352 C If option globalFile is desired but does not work or if
                1353 C globalFile is too slow, then try using single-CPU I/O.
                1354       if (useSingleCpuIO) then
                1355
                1356 C Master thread of process 0, only, opens a global file
                1357        _BEGIN_MASTER( myThid )
b714306922 Jean*1358         IF( myProcId .EQ. 0 ) THEN
47c8a35ff3 Jean*1359          write(dataFname,'(2a)') fName(1:IL),'.data'
023d5a3a61 Patr*1360          length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
                1361          if (irecord .EQ. 1) then
                1362           open( dUnit, file=dataFName, status=_NEW_STATUS,
                1363      &        access='direct', recl=length_of_rec )
                1364          else
                1365           open( dUnit, file=dataFName, status=_OLD_STATUS,
                1366      &        access='direct', recl=length_of_rec )
                1367          endif
                1368         ENDIF
                1369        _END_MASTER( myThid )
                1370
                1371 C Gather array and write it to file, one vertical level at a time
                1372        DO k=1,nLocz
b714306922 Jean*1373 C Loop over all processors
023d5a3a61 Patr*1374         do jp=1,nPy
                1375         do ip=1,nPx
                1376         DO bj = myByLo(myThid), myByHi(myThid)
                1377          DO bi = myBxLo(myThid), myBxHi(myThid)
                1378           DO J=1,sNy
                1379            JJ=((jp-1)*nSy+(bj-1))*sNy+J
                1380            DO I=1,sNx
                1381             II=((ip-1)*nSx+(bi-1))*sNx+I
                1382             global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
                1383            ENDDO
                1384           ENDDO
                1385          ENDDO
                1386         ENDDO
                1387         enddo
                1388         enddo
                1389         _BEGIN_MASTER( myThid )
b714306922 Jean*1390          IF( myProcId .EQ. 0 ) THEN
023d5a3a61 Patr*1391           irec=k+nLocz*(irecord-1)
                1392           if (filePrec .eq. precFloat32) then
                1393            DO J=1,Ny
                1394             DO I=1,Nx
                1395              xy_buffer_r4(I,J) = global(I,J)
                1396             ENDDO
                1397            ENDDO
                1398 #ifdef _BYTESWAPIO
                1399            call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
                1400 #endif
                1401            write(dUnit,rec=irec) xy_buffer_r4
                1402           elseif (filePrec .eq. precFloat64) then
                1403            DO J=1,Ny
                1404             DO I=1,Nx
                1405              xy_buffer_r8(I,J) = global(I,J)
                1406             ENDDO
                1407            ENDDO
                1408 #ifdef _BYTESWAPIO
                1409            call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
                1410 #endif
                1411            write(dUnit,rec=irec) xy_buffer_r8
                1412           else
                1413            write(msgbuf,'(a)')
                1414      &       ' MDSWRITEFIELD: illegal value for filePrec'
                1415            call print_error( msgbuf, mythid )
                1416            stop 'ABNORMAL END: S/R MDSWRITEFIELD'
                1417           endif
                1418          ENDIF
                1419         _END_MASTER( myThid )
                1420        ENDDO
                1421
                1422 C Close data-file and create meta-file
                1423        _BEGIN_MASTER( myThid )
b714306922 Jean*1424         IF( myProcId .EQ. 0 ) THEN
023d5a3a61 Patr*1425          close( dUnit )
47c8a35ff3 Jean*1426          write(metaFName,'(2a)') fName(1:IL),'.meta'
023d5a3a61 Patr*1427          dimList(1,1)=Nx
                1428          dimList(2,1)=1
                1429          dimList(3,1)=Nx
                1430          dimList(1,2)=Ny
                1431          dimList(2,2)=1
                1432          dimList(3,2)=Ny
                1433          dimList(1,3)=nLocz
                1434          dimList(2,3)=1
                1435          dimList(3,3)=nLocz
b714306922 Jean*1436          nDims=3
                1437          if (nLocz .EQ. 1) nDims=2
                1438          map2gl(1) = 0
                1439          map2gl(2) = 1
                1440          CALL MDS_WRITE_META(
                1441      I              metaFName, dataFName, the_run_name, ' ',
                1442      I              filePrec, nDims, dimList, map2gl, 0, blank8c,
a50692f9cd Jean*1443      I              0, dummyRL, oneRL, irecord, myIter, myThid )
023d5a3a61 Patr*1444         ENDIF
                1445        _END_MASTER( myThid )
                1446 C To be safe, make other processes wait for I/O completion
                1447        _BARRIER
                1448
                1449       elseif ( .NOT. useSingleCpuIO ) then
                1450       _BEGIN_MASTER( myThid )
                1451 #endif /* ALLOW_USE_MPI */
                1452 cph-usesingle)
                1453
b714306922 Jean*1454 C Loop over all processors
5ae46f2adb Patr*1455       do jp=1,nPy
                1456       do ip=1,nPx
                1457 C Loop over all tiles
                1458       do bj=1,nSy
                1459        do bi=1,nSx
                1460 C If we are writing to a tiled MDS file then we open each one here
                1461          iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
                1462          jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
47c8a35ff3 Jean*1463          write(dataFname,'(2a,i3.3,a,i3.3,a)')
5ae46f2adb Patr*1464      &              fName(1:IL),'.',iG,'.',jG,'.data'
                1465          if (irecord .EQ. 1) then
                1466           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
                1467           open( dUnit, file=dataFName, status=_NEW_STATUS,
                1468      &       access='direct', recl=length_of_rec )
                1469           fileIsOpen=.TRUE.
                1470          else
                1471           length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
                1472           open( dUnit, file=dataFName, status=_OLD_STATUS,
                1473      &       access='direct', recl=length_of_rec )
                1474           fileIsOpen=.TRUE.
                1475          endif
                1476         if (fileIsOpen) then
                1477          do k=1,nLocz
                1478           do j=1,sNy
47c8a35ff3 Jean*1479              do i=1,sNx
                1480                 arr(i,j,k,bi,bj)=arr_gl(i,bi,ip,j,bj,jp,k)
5ae46f2adb Patr*1481              enddo
                1482             iG = 0
                1483             jG = 0
                1484             irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
                1485            if (filePrec .eq. precFloat32) then
                1486             if (arrType .eq. 'RS') then
b2fffc7e1a Jean*1487 #ifdef REAL4_IS_SLOW
5ae46f2adb Patr*1488              call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
b2fffc7e1a Jean*1489 #endif
5ae46f2adb Patr*1490             elseif (arrType .eq. 'RL') then
                1491              call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
                1492             else
                1493              write(msgbuf,'(a)')
                1494      &         ' MDSWRITEFIELD_GL: illegal value for arrType'
                1495              call print_error( msgbuf, mythid )
                1496              stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                1497             endif
                1498 #ifdef _BYTESWAPIO
                1499             call MDS_BYTESWAPR4( sNx, r4seg )
                1500 #endif
                1501             write(dUnit,rec=irec) r4seg
                1502            elseif (filePrec .eq. precFloat64) then
                1503             if (arrType .eq. 'RS') then
b2fffc7e1a Jean*1504 #ifdef REAL4_IS_SLOW
5ae46f2adb Patr*1505              call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
b2fffc7e1a Jean*1506 #endif
5ae46f2adb Patr*1507             elseif (arrType .eq. 'RL') then
                1508              call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
                1509             else
                1510              write(msgbuf,'(a)')
                1511      &         ' MDSWRITEFIELD_GL: illegal value for arrType'
                1512              call print_error( msgbuf, mythid )
                1513              stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                1514             endif
                1515 #ifdef _BYTESWAPIO
                1516             call MDS_BYTESWAPR8( sNx, r8seg )
                1517 #endif
                1518             write(dUnit,rec=irec) r8seg
                1519            else
                1520             write(msgbuf,'(a)')
                1521      &        ' MDSWRITEFIELD_GL: illegal value for filePrec'
                1522             call print_error( msgbuf, mythid )
                1523             stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                1524            endif
                1525 C End of j loop
                1526           enddo
                1527 C End of k loop
                1528          enddo
                1529         else
                1530          write(msgbuf,'(a)')
                1531      &     ' MDSWRITEFIELD_GL: I should never get to this point'
                1532          call print_error( msgbuf, mythid )
                1533          stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
                1534         endif
                1535 C If we were writing to a tiled MDS file then we close it here
                1536         if (fileIsOpen) then
                1537          close( dUnit )
                1538          fileIsOpen = .FALSE.
                1539         endif
                1540 C Create meta-file for each tile if we are tiling
                1541          iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
                1542          jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
47c8a35ff3 Jean*1543          write(metaFname,'(2a,i3.3,a,i3.3,a)')
5ae46f2adb Patr*1544      &              fName(1:IL),'.',iG,'.',jG,'.meta'
                1545          dimList(1,1)=Nx
                1546          dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
                1547          dimList(3,1)=((ip-1)*nSx+bi)*sNx
                1548          dimList(1,2)=Ny
                1549          dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
                1550          dimList(3,2)=((jp-1)*nSy+bj)*sNy
                1551          dimList(1,3)=Nr
                1552          dimList(2,3)=1
                1553          dimList(3,3)=Nr
b714306922 Jean*1554          nDims=3
                1555          if (nLocz .EQ. 1) nDims=2
                1556          map2gl(1) = 0
                1557          map2gl(2) = 1
                1558          CALL MDS_WRITE_META(
                1559      I              metaFName, dataFName, the_run_name, ' ',
                1560      I              filePrec, nDims, dimList, map2gl, 0, blank8c,
a50692f9cd Jean*1561      I              0, dummyRL, oneRL, irecord, myIter, myThid )
5ae46f2adb Patr*1562 C End of bi,bj loops
                1563        enddo
                1564       enddo
                1565 C End of ip,jp loops
                1566        enddo
                1567       enddo
                1568
                1569       _END_MASTER( myThid )
ffa487b126 Alis*1570
023d5a3a61 Patr*1571 #ifdef ALLOW_USE_MPI
                1572 C endif useSingleCpuIO
                1573       endif
                1574 #endif /* ALLOW_USE_MPI */
                1575
b714306922 Jean*1576 #else /* ALLOW_CTRL */
                1577       STOP 'ABNORMAL END: S/R MDSWRITEFIELD_2D_GL is empty'
de7dc9fe18 Oliv*1578 #endif /* ALLOW_CTRL */
ffa487b126 Alis*1579 C     ------------------------------------------------------------------
b714306922 Jean*1580       RETURN
                1581       END