/[MITgcm]/MITgcm/pkg/mdsio/mdsio_gl.F
ViewVC logotype

Diff of /MITgcm/pkg/mdsio/mdsio_gl.F

Parent Directory Parent Directory | Revision Log Revision Log | View Revision Graph Revision Graph | View Patch Patch

revision 1.1 by adcroft, Tue Mar 6 15:28:54 2001 UTC revision 1.3 by heimbach, Tue Jul 8 15:00:26 2003 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
 C $Name$  
2    
3  #include "MDSIO_OPTIONS.h"  #include "CPP_OPTIONS.h"
4    
5    C The five "public" routines supplied here are:
6    C
7    C MDSREADFIELD   - read model field from direct access global or tiled MDS file
8    C MDSWRITEFIELD  - write model field to direct access global or tiled MDS file
9    C MDSFINDUNIT    - returns an available (unused) I/O channel
10    C MDSREADVECTOR  - read vector from direct access global or tiled MDS file
11    C MDSWRITEVECTOR - write vector to direct access global or tiled MDS file
12    C
13    C all other routines are "private" to these utilities and ought
14    C not be accessed directly from the main code.
15    C
16    C Created:  03/16/99 adcroft@mit.edu
17    C Modified: 03/23/99 adcroft@mit.edu
18    C           To work with multiple records
19    C Modified: 03/29/99 eckert@mit.edu
20    C           Added arbitrary vector capability
21    C Modified: 07/27/99 eckert@mit.edu
22    C           Customized for state estimation (--> active_file_control.F)
23    C           this relates only to *mdsreadvector* and *mdswritevector*
24    C Modified: 07/28/99 eckert@mit.edu
25    C           inserted calls to *print_message* and *print_error*
26    C
27    C To be modified to work with MITgcmuv message routines.
28    
29    #undef  SAFE_IO
30    
31    #ifdef SAFE_IO
32    #define _NEW_STATUS 'new'
33    #else
34    #define _NEW_STATUS 'unknown'
35    #endif
36    
37    #ifdef ALLOW_AUTODIFF_TAMC
38    #define _OLD_STATUS 'unknown'
39    #else
40    #define _OLD_STATUS 'old'
41    #endif
42    
43  C=======================================================================  C=======================================================================
44        SUBROUTINE MDSREADFIELD_GL(        SUBROUTINE MDSREADFIELD_3D_GL(
45       I   fName,       I   fName,
46       I   filePrec,       I   filePrec,
47       I   arrType,       I   arrType,
# Line 38  C arr *but* the overlaps are *not* updat Line 75  C arr *but* the overlaps are *not* updat
75  C be called. This is because the routine is sometimes called from  C be called. This is because the routine is sometimes called from
76  C within a MASTER_THID region.  C within a MASTER_THID region.
77  C  C
78  C Created: 03/16/99 anonymous@nowhere.com  C Created: 03/16/99 adcroft@mit.edu
79    
80        implicit none        implicit none
81  C Global variables / common blocks  C Global variables / common blocks
# Line 51  C Routine arguments Line 88  C Routine arguments
88        integer filePrec        integer filePrec
89        character*(2) arrType        character*(2) arrType
90        integer nNz        integer nNz
91        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nNz)        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
92        integer irecord        integer irecord
93        integer myThid        integer myThid
   
 #ifdef ALLOW_BROKEN_MDSIO_GL  
   
94  C Functions  C Functions
95        integer ILNBLNK        integer ILNBLNK
96        integer MDS_RECLEN        integer MDS_RECLEN
# Line 64  C Local variables Line 98  C Local variables
98        character*(80) dataFName        character*(80) dataFName
99        integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL        integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
100        logical exst        logical exst
 C The following declaration isn't F77 and breaks under several compilers.  
 C To fix this, copies of the routines MDS_SEG4toRS, etc. need to be  
 C written to act on arrays shaped as "arr_gl" is above.  
 C          ...to be done by someone in ECCO...  
101        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)        _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
102        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
103        Real*8 r8seg(sNx)        Real*8 r8seg(sNx)
# Line 139  C If we are reading from a tiled MDS fil Line 169  C If we are reading from a tiled MDS fil
169  C Of course, we only open the file if the tile is "active"  C Of course, we only open the file if the tile is "active"
170  C (This is a place-holder for the active/passive mechanism  C (This is a place-holder for the active/passive mechanism
171           if (exst) then           if (exst) then
172            write(msgbuf,'(a,a)')            if ( debugLevel .GE. debLevA ) then
173               write(msgbuf,'(a,a)')
174       &      ' MDSREADFIELD_GL: opening file: ',dataFName       &      ' MDSREADFIELD_GL: opening file: ',dataFName
175            call print_message( msgbuf, standardmessageunit,             call print_message( msgbuf, standardmessageunit,
176       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
177              endif
178            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
179            open( dUnit, file=dataFName, status='old',            open( dUnit, file=dataFName, status='old',
180       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 161  C (This is a place-holder for the active Line 193  C (This is a place-holder for the active
193          endif          endif
194    
195          if (fileIsOpen) then          if (fileIsOpen) then
196           do k=1,nNz           do k=1,Nr
197            do j=1,sNy            do j=1,sNy
198              iG = 0              iG = 0
199              jG = 0              jG = 0
200              irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
201             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
202              read(dUnit,rec=irec) r4seg              read(dUnit,rec=irec) r4seg
203  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
204              call MDS_BYTESWAPR4( sNx, r4seg )              call MDS_BYTESWAPR4( sNx, r4seg )
205  #endif  #endif
206              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
207               call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .TRUE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
208              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
209               call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .TRUE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
210              else              else
211               write(msgbuf,'(a)')               write(msgbuf,'(a)')
212       &         ' MDSREADFIELD_GL: illegal value for arrType'       &         ' MDSREADFIELD_GL: illegal value for arrType'
# Line 187  C (This is a place-holder for the active Line 219  C (This is a place-holder for the active
219              call MDS_BYTESWAPR8( sNx, r8seg )              call MDS_BYTESWAPR8( sNx, r8seg )
220  #endif  #endif
221              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
222               call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .TRUE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
223              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
224               call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .TRUE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
225              else              else
226               write(msgbuf,'(a)')               write(msgbuf,'(a)')
227       &         ' MDSREADFIELD_GL: illegal value for arrType'       &         ' MDSREADFIELD_GL: illegal value for arrType'
# Line 236  C     ---------------------------------- Line 268  C     ----------------------------------
268  C=======================================================================  C=======================================================================
269    
270  C=======================================================================  C=======================================================================
271        SUBROUTINE MDSWRITEFIELD_GL(        SUBROUTINE MDSWRITEFIELD_3D_GL(
272       I   fName,       I   fName,
273       I   filePrec,       I   filePrec,
274       I   arrType,       I   arrType,
# Line 295  C Routine arguments Line 327  C Routine arguments
327        integer nNz        integer nNz
328  cph(  cph(
329  cph      Real arr(*)  cph      Real arr(*)
330        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nNz)        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
331  cph)  cph)
332        integer irecord        integer irecord
333        integer myIter        integer myIter
# Line 361  C If we are writing to a tiled MDS file Line 393  C If we are writing to a tiled MDS file
393            fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
394           endif           endif
395          if (fileIsOpen) then          if (fileIsOpen) then
396           do k=1,nNz           do k=1,Nr
397            do j=1,sNy            do j=1,sNy
398               do ii=1,sNx               do ii=1,sNx
399                  arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)                  arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
400               enddo               enddo
401              iG = 0              iG = 0
402              jG = 0              jG = 0
403              irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
404             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
405              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
406               call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .FALSE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
407              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
408               call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .FALSE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
409              else              else
410               write(msgbuf,'(a)')               write(msgbuf,'(a)')
411       &         ' MDSWRITEFIELD_GL: illegal value for arrType'       &         ' MDSWRITEFIELD_GL: illegal value for arrType'
# Line 386  C If we are writing to a tiled MDS file Line 418  C If we are writing to a tiled MDS file
418              write(dUnit,rec=irec) r4seg              write(dUnit,rec=irec) r4seg
419             elseif (filePrec .eq. precFloat64) then             elseif (filePrec .eq. precFloat64) then
420              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
421               call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .FALSE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
422              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
423               call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .FALSE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
424              else              else
425               write(msgbuf,'(a)')               write(msgbuf,'(a)')
426       &         ' MDSWRITEFIELD_GL: illegal value for arrType'       &         ' MDSWRITEFIELD_GL: illegal value for arrType'
# Line 435  C Create meta-file for each tile if we a Line 467  C Create meta-file for each tile if we a
467           dimList(2,3)=1           dimList(2,3)=1
468           dimList(3,3)=Nr           dimList(3,3)=Nr
469           ndims=3           ndims=3
470           if (nNz .EQ. 1) ndims=2           if (Nr .EQ. 1) ndims=2
471           call MDSWRITEMETA( metaFName, dataFName,           call MDSWRITEMETA( metaFName, dataFName,
472       &     filePrec, ndims, dimList, irecord, myIter, mythid )       &     filePrec, ndims, dimList, irecord, myIter, mythid )
473  C End of bi,bj loops  C End of bi,bj loops
# Line 448  C End of ip,jp loops Line 480  C End of ip,jp loops
480    
481        _END_MASTER( myThid )        _END_MASTER( myThid )
482    
483    C     ------------------------------------------------------------------
484          return
485          end
486    C=======================================================================
487    
488    C=======================================================================
489          SUBROUTINE MDSREADFIELD_2D_GL(
490         I   fName,
491         I   filePrec,
492         I   arrType,
493         I   nNz,
494         O   arr_gl,
495         I   irecord,
496         I   myThid )
497    C
498    C Arguments:
499    C
500    C fName         string  base name for file to read
501    C filePrec      integer number of bits per word in file (32 or 64)
502    C arrType       char(2) declaration of "arr": either "RS" or "RL"
503    C nNz           integer size of third dimension: normally either 1 or Nr
504    C arr           RS/RL   array to read into, arr(:,:,nNz,:,:)
505    C irecord       integer record number to read
506    C myThid        integer thread identifier
507    C
508    C MDSREADFIELD first checks to see if the file "fName" exists, then
509    C if the file "fName.data" exists and finally the tiled files of the
510    C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
511    C read because it is difficult to parse files in fortran.
512    C The precision of the file is decsribed by filePrec, set either
513    C to floatPrec32 or floatPrec64. The precision or declaration of
514    C the array argument must be consistently described by the char*(2)
515    C string arrType, either "RS" or "RL". nNz allows for both 2-D and
516    C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
517    C nNz=Nr implies a 3-D model field. irecord is the record number
518    C to be read and must be >= 1. The file data is stored in
519    C arr *but* the overlaps are *not* updated. ie. An exchange must
520    C be called. This is because the routine is sometimes called from
521    C within a MASTER_THID region.
522    C
523    C Created: 03/16/99 adcroft@mit.edu
524    
525          implicit none
526    C Global variables / common blocks
527    #include "SIZE.h"
528    #include "EEPARAMS.h"
529    #include "PARAMS.h"
530    
531    C Routine arguments
532          character*(*) fName
533          integer filePrec
534          character*(2) arrType
535          integer nNz, nLocz
536          parameter (nLocz = 1)
537          _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
538          integer irecord
539          integer myThid
540    C Functions
541          integer ILNBLNK
542          integer MDS_RECLEN
543    C Local variables
544          character*(80) dataFName
545          integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
546          logical exst
547          _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
548          Real*4 r4seg(sNx)
549          Real*8 r8seg(sNx)
550          logical globalFile,fileIsOpen
551          integer length_of_rec
552          character*(max_len_mbuf) msgbuf
553    C     ------------------------------------------------------------------
554    
555    C Only do I/O if I am the master thread
556          _BEGIN_MASTER( myThid )
557    
558    C Record number must be >= 1
559          if (irecord .LT. 1) then
560           write(msgbuf,'(a,i9.8)')
561         &   ' MDSREADFIELD_GL: argument irecord = ',irecord
562           call print_message( msgbuf, standardmessageunit,
563         &                     SQUEEZE_RIGHT , mythid)
564           write(msgbuf,'(a)')
565         &   ' MDSREADFIELD_GL: Invalid value for irecord'
566           call print_error( msgbuf, mythid )
567           stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
568          endif
569    
570    C Assume nothing
571          globalFile = .FALSE.
572          fileIsOpen = .FALSE.
573          IL=ILNBLNK( fName )
574    
575    C Assign a free unit number as the I/O channel for this routine
576          call MDSFINDUNIT( dUnit, mythid )
577    
578    C Check first for global file with simple name (ie. fName)
579          dataFName = fName
580          inquire( file=dataFname, exist=exst )
581          if (exst) then
582           write(msgbuf,'(a,a)')
583         &   ' MDSREADFIELD: opening global file: ',dataFName
584           call print_message( msgbuf, standardmessageunit,
585         &                     SQUEEZE_RIGHT , mythid)
586           stop " xx, adxx, weights and masks are not supposed to be global"
587          endif
588    
589    C If negative check for global file with MDS name (ie. fName.data)
590          if (.NOT. globalFile) then
591           write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
592           inquire( file=dataFname, exist=exst )
593           if (exst) then
594            write(msgbuf,'(a,a)')
595         &    ' MDSREADFIELD_GL: opening global file: ',dataFName
596            call print_message( msgbuf, standardmessageunit,
597         &                      SQUEEZE_RIGHT , mythid)
598            globalFile = .TRUE.
599           stop " xx, adxx, weights and masks are not supposed to be global"
600           endif
601          endif
602    C Loop over all processors    
603          do jp=1,nPy
604          do ip=1,nPx
605    C Loop over all tiles
606          do bj=1,nSy
607          do bi=1,nSx
608    C If we are reading from a tiled MDS file then we open each one here
609            if (.NOT. globalFile) then
610             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
611             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
612             write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
613         &              fName(1:IL),'.',iG,'.',jG,'.data'
614             inquire( file=dataFname, exist=exst )
615    C Of course, we only open the file if the tile is "active"
616    C (This is a place-holder for the active/passive mechanism
617             if (exst) then
618              if ( debugLevel .GE. debLevA ) then
619               write(msgbuf,'(a,a)')
620         &      ' MDSREADFIELD_GL: opening file: ',dataFName
621               call print_message( msgbuf, standardmessageunit,
622         &                        SQUEEZE_RIGHT , mythid)
623              endif
624              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
625              open( dUnit, file=dataFName, status='old',
626         &        access='direct', recl=length_of_rec )
627              fileIsOpen=.TRUE.
628             else
629              fileIsOpen=.FALSE.
630              write(msgbuf,'(a,a)')
631         &      ' MDSREADFIELD_GL: filename: ',dataFName
632              call print_message( msgbuf, standardmessageunit,
633         &                        SQUEEZE_RIGHT , mythid)
634              write(msgbuf,'(a)')
635         &      ' MDSREADFIELD_GL: File does not exist'
636              call print_error( msgbuf, mythid )
637              stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
638             endif
639            endif
640    
641            if (fileIsOpen) then
642             do k=1,nLocz
643              do j=1,sNy
644                iG = 0
645                jG = 0
646                irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
647               if (filePrec .eq. precFloat32) then
648                read(dUnit,rec=irec) r4seg
649    #ifdef _BYTESWAPIO
650                call MDS_BYTESWAPR4( sNx, r4seg )
651  #endif  #endif
652                if (arrType .eq. 'RS') then
653                 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
654                elseif (arrType .eq. 'RL') then
655                 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
656                else
657                 write(msgbuf,'(a)')
658         &         ' MDSREADFIELD_GL: illegal value for arrType'
659                 call print_error( msgbuf, mythid )
660                 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
661                endif
662               elseif (filePrec .eq. precFloat64) then
663                read(dUnit,rec=irec) r8seg
664    #ifdef _BYTESWAPIO
665                call MDS_BYTESWAPR8( sNx, r8seg )
666    #endif
667                if (arrType .eq. 'RS') then
668                 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
669                elseif (arrType .eq. 'RL') then
670                 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
671                else
672                 write(msgbuf,'(a)')
673         &         ' MDSREADFIELD_GL: illegal value for arrType'
674                 call print_error( msgbuf, mythid )
675                 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
676                endif
677               else
678                write(msgbuf,'(a)')
679         &        ' MDSREADFIELD_GL: illegal value for filePrec'
680                call print_error( msgbuf, mythid )
681                stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
682               endif
683           do ii=1,sNx
684            arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
685           enddo
686    
687    C End of j loop
688              enddo
689    C End of k loop
690             enddo
691             if (.NOT. globalFile) then
692              close( dUnit )
693              fileIsOpen = .FALSE.
694             endif
695            endif
696    C End of bi,bj loops
697           enddo
698          enddo
699    C End of ip,jp loops
700           enddo
701          enddo
702    
703    C If global file was opened then close it
704          if (fileIsOpen .AND. globalFile) then
705           close( dUnit )
706           fileIsOpen = .FALSE.
707          endif
708    
709          _END_MASTER( myThid )
710    
711    C     ------------------------------------------------------------------
712          return
713          end
714    C=======================================================================
715    
716    C=======================================================================
717          SUBROUTINE MDSWRITEFIELD_2D_GL(
718         I   fName,
719         I   filePrec,
720         I   arrType,
721         I   nNz,
722         I   arr_gl,
723         I   irecord,
724         I   myIter,
725         I   myThid )
726    C
727    C Arguments:
728    C
729    C fName         string  base name for file to written
730    C filePrec      integer number of bits per word in file (32 or 64)
731    C arrType       char(2) declaration of "arr": either "RS" or "RL"
732    C nNz           integer size of third dimension: normally either 1 or Nr
733    C arr           RS/RL   array to write, arr(:,:,nNz,:,:)
734    C irecord       integer record number to read
735    C myIter        integer time step number
736    C myThid        integer thread identifier
737    C
738    C MDSWRITEFIELD creates either a file of the form "fName.data" and
739    C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
740    C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
741    C "fName.xxx.yyy.meta". A meta-file is always created.
742    C Currently, the meta-files are not read because it is difficult
743    C to parse files in fortran. We should read meta information before
744    C adding records to an existing multi-record file.
745    C The precision of the file is decsribed by filePrec, set either
746    C to floatPrec32 or floatPrec64. The precision or declaration of
747    C the array argument must be consistently described by the char*(2)
748    C string arrType, either "RS" or "RL". nNz allows for both 2-D and
749    C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
750    C nNz=Nr implies a 3-D model field. irecord is the record number
751    C to be read and must be >= 1. NOTE: It is currently assumed that
752    C the highest record number in the file was the last record written.
753    C Nor is there a consistency check between the routine arguments and file.
754    C ie. if your write record 2 after record 4 the meta information
755    C will record the number of records to be 2. This, again, is because
756    C we have read the meta information. To be fixed.
757    C
758    C Created: 03/16/99 adcroft@mit.edu
759    C
760    C Changed: 05/31/00 heimbach@mit.edu
761    C          open(dUnit, ..., status='old', ... -> status='unknown'
762    
763          implicit none
764    C Global variables / common blocks
765    #include "SIZE.h"
766    #include "EEPARAMS.h"
767    #include "PARAMS.h"
768    
769    C Routine arguments
770          character*(*) fName
771          integer filePrec
772          character*(2) arrType
773          integer nNz, nLocz
774          parameter (nLocz = 1)
775    cph(
776    cph      Real arr(*)
777          _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
778    cph)
779          integer irecord
780          integer myIter
781          integer myThid
782    C Functions
783          integer ILNBLNK
784          integer MDS_RECLEN
785    C Local variables
786          character*(80) dataFName,metaFName
787          integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
788          Real*4 r4seg(sNx)
789          Real*8 r8seg(sNx)
790          _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
791          integer dimList(3,3),ndims
792          integer length_of_rec
793          logical fileIsOpen
794          character*(max_len_mbuf) msgbuf
795    C     ------------------------------------------------------------------
796    
797    C Only do I/O if I am the master thread
798          _BEGIN_MASTER( myThid )
799    
800    C Record number must be >= 1
801          if (irecord .LT. 1) then
802           write(msgbuf,'(a,i9.8)')
803         &   ' MDSWRITEFIELD_GL: argument irecord = ',irecord
804           call print_message( msgbuf, standardmessageunit,
805         &                     SQUEEZE_RIGHT , mythid)
806           write(msgbuf,'(a)')
807         &   ' MDSWRITEFIELD_GL: invalid value for irecord'
808           call print_error( msgbuf, mythid )
809           stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
810          endif
811    
812    C Assume nothing
813          fileIsOpen=.FALSE.
814          IL=ILNBLNK( fName )
815    
816    C Assign a free unit number as the I/O channel for this routine
817          call MDSFINDUNIT( dUnit, mythid )
818    
819    
820    C Loop over all processors    
821          do jp=1,nPy
822          do ip=1,nPx
823    C Loop over all tiles
824          do bj=1,nSy
825           do bi=1,nSx
826    C If we are writing to a tiled MDS file then we open each one here
827             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
828             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
829             write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
830         &              fName(1:IL),'.',iG,'.',jG,'.data'
831             if (irecord .EQ. 1) then
832              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
833              open( dUnit, file=dataFName, status=_NEW_STATUS,
834         &       access='direct', recl=length_of_rec )
835              fileIsOpen=.TRUE.
836             else
837              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
838              open( dUnit, file=dataFName, status=_OLD_STATUS,
839         &       access='direct', recl=length_of_rec )
840              fileIsOpen=.TRUE.
841             endif
842            if (fileIsOpen) then
843             do k=1,nLocz
844              do j=1,sNy
845                 do ii=1,sNx
846                    arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
847                 enddo
848                iG = 0
849                jG = 0
850                irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
851               if (filePrec .eq. precFloat32) then
852                if (arrType .eq. 'RS') then
853                 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
854                elseif (arrType .eq. 'RL') then
855                 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
856                else
857                 write(msgbuf,'(a)')
858         &         ' MDSWRITEFIELD_GL: illegal value for arrType'
859                 call print_error( msgbuf, mythid )
860                 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
861                endif
862    #ifdef _BYTESWAPIO
863                call MDS_BYTESWAPR4( sNx, r4seg )
864    #endif
865                write(dUnit,rec=irec) r4seg
866               elseif (filePrec .eq. precFloat64) then
867                if (arrType .eq. 'RS') then
868                 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
869                elseif (arrType .eq. 'RL') then
870                 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
871                else
872                 write(msgbuf,'(a)')
873         &         ' MDSWRITEFIELD_GL: illegal value for arrType'
874                 call print_error( msgbuf, mythid )
875                 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
876                endif
877    #ifdef _BYTESWAPIO
878                call MDS_BYTESWAPR8( sNx, r8seg )
879    #endif
880                write(dUnit,rec=irec) r8seg
881               else
882                write(msgbuf,'(a)')
883         &        ' MDSWRITEFIELD_GL: illegal value for filePrec'
884                call print_error( msgbuf, mythid )
885                stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
886               endif
887    C End of j loop
888              enddo
889    C End of k loop
890             enddo
891            else
892             write(msgbuf,'(a)')
893         &     ' MDSWRITEFIELD_GL: I should never get to this point'
894             call print_error( msgbuf, mythid )
895             stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
896            endif
897    C If we were writing to a tiled MDS file then we close it here
898            if (fileIsOpen) then
899             close( dUnit )
900             fileIsOpen = .FALSE.
901            endif
902    C Create meta-file for each tile if we are tiling
903             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
904             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
905             write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
906         &              fName(1:IL),'.',iG,'.',jG,'.meta'
907             dimList(1,1)=Nx
908             dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
909             dimList(3,1)=((ip-1)*nSx+bi)*sNx
910             dimList(1,2)=Ny
911             dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
912             dimList(3,2)=((jp-1)*nSy+bj)*sNy
913             dimList(1,3)=Nr
914             dimList(2,3)=1
915             dimList(3,3)=Nr
916             ndims=3
917             if (nLocz .EQ. 1) ndims=2
918             call MDSWRITEMETA( metaFName, dataFName,
919         &     filePrec, ndims, dimList, irecord, myIter, mythid )
920    C End of bi,bj loops
921           enddo
922          enddo
923    C End of ip,jp loops
924           enddo
925          enddo
926    
927    
928          _END_MASTER( myThid )
929    
930  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
931        return        return
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.3
  ViewVC Help
Powered by ViewVC 1.1.22