/[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.6 by heimbach, Wed Nov 17 03:04:36 2004 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
 C $Name$  
2    
3  #include "MDSIO_OPTIONS.h"  #include "MDSIO_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  C=======================================================================  C=======================================================================
30        SUBROUTINE MDSREADFIELD_GL(        SUBROUTINE MDSREADFIELD_3D_GL(
31       I   fName,       I   fName,
32       I   filePrec,       I   filePrec,
33       I   arrType,       I   arrType,
# Line 38  C arr *but* the overlaps are *not* updat Line 61  C arr *but* the overlaps are *not* updat
61  C be called. This is because the routine is sometimes called from  C be called. This is because the routine is sometimes called from
62  C within a MASTER_THID region.  C within a MASTER_THID region.
63  C  C
64  C Created: 03/16/99 anonymous@nowhere.com  C Created: 03/16/99 adcroft@mit.edu
65    
66        implicit none        implicit none
67  C Global variables / common blocks  C Global variables / common blocks
# Line 51  C Routine arguments Line 74  C Routine arguments
74        integer filePrec        integer filePrec
75        character*(2) arrType        character*(2) arrType
76        integer nNz        integer nNz
77        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nNz)        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
78        integer irecord        integer irecord
79        integer myThid        integer myThid
   
 #ifdef ALLOW_BROKEN_MDSIO_GL  
   
80  C Functions  C Functions
81        integer ILNBLNK        integer ILNBLNK
82        integer MDS_RECLEN        integer MDS_RECLEN
# Line 64  C Local variables Line 84  C Local variables
84        character*(80) dataFName        character*(80) dataFName
85        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
86        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...  
87        _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)
88        Real*4 r4seg(sNx)        Real*4 r4seg(sNx)
89        Real*8 r8seg(sNx)        Real*8 r8seg(sNx)
# Line 107  C Check first for global file with simpl Line 123  C Check first for global file with simpl
123       &   ' MDSREADFIELD: opening global file: ',dataFName       &   ' MDSREADFIELD: opening global file: ',dataFName
124         call print_message( msgbuf, standardmessageunit,         call print_message( msgbuf, standardmessageunit,
125       &                     SQUEEZE_RIGHT , mythid)       &                     SQUEEZE_RIGHT , mythid)
        stop " xx, adxx, weights and masks are not supposed to be global"  
126        endif        endif
127    
128  C If negative check for global file with MDS name (ie. fName.data)  C If negative check for global file with MDS name (ie. fName.data)
# Line 120  C If negative check for global file with Line 135  C If negative check for global file with
135          call print_message( msgbuf, standardmessageunit,          call print_message( msgbuf, standardmessageunit,
136       &                      SQUEEZE_RIGHT , mythid)       &                      SQUEEZE_RIGHT , mythid)
137          globalFile = .TRUE.          globalFile = .TRUE.
        stop " xx, adxx, weights and masks are not supposed to be global"  
138         endif         endif
139        endif        endif
140  C Loop over all processors      C Loop over all processors    
# Line 139  C If we are reading from a tiled MDS fil Line 153  C If we are reading from a tiled MDS fil
153  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"
154  C (This is a place-holder for the active/passive mechanism  C (This is a place-holder for the active/passive mechanism
155           if (exst) then           if (exst) then
156            write(msgbuf,'(a,a)')            if ( debugLevel .GE. debLevA ) then
157               write(msgbuf,'(a,a)')
158       &      ' MDSREADFIELD_GL: opening file: ',dataFName       &      ' MDSREADFIELD_GL: opening file: ',dataFName
159            call print_message( msgbuf, standardmessageunit,             call print_message( msgbuf, standardmessageunit,
160       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
161              endif
162            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )            length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
163            open( dUnit, file=dataFName, status='old',            open( dUnit, file=dataFName, status='old',
164       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
# Line 153  C (This is a place-holder for the active Line 169  C (This is a place-holder for the active
169       &      ' MDSREADFIELD_GL: filename: ',dataFName       &      ' MDSREADFIELD_GL: filename: ',dataFName
170            call print_message( msgbuf, standardmessageunit,            call print_message( msgbuf, standardmessageunit,
171       &                        SQUEEZE_RIGHT , mythid)       &                        SQUEEZE_RIGHT , mythid)
172              call print_error( msgbuf, mythid )
173            write(msgbuf,'(a)')            write(msgbuf,'(a)')
174       &      ' MDSREADFIELD_GL: File does not exist'       &      ' MDSREADFIELD_GL: File does not exist'
175              call print_message( msgbuf, standardmessageunit,
176         &                        SQUEEZE_RIGHT , mythid)
177            call print_error( msgbuf, mythid )            call print_error( msgbuf, mythid )
178            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'            stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
179           endif           endif
180          endif          endif
181    
182          if (fileIsOpen) then          if (fileIsOpen) then
183           do k=1,nNz           do k=1,Nr
184            do j=1,sNy            do j=1,sNy
185              iG = 0              iG = 0
186              jG = 0              jG = 0
187              irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
188             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
189              read(dUnit,rec=irec) r4seg              read(dUnit,rec=irec) r4seg
190  #ifdef _BYTESWAPIO  #ifdef _BYTESWAPIO
191              call MDS_BYTESWAPR4( sNx, r4seg )              call MDS_BYTESWAPR4( sNx, r4seg )
192  #endif  #endif
193              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
194               call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .TRUE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
195              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
196               call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .TRUE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
197              else              else
198               write(msgbuf,'(a)')               write(msgbuf,'(a)')
199       &         ' MDSREADFIELD_GL: illegal value for arrType'       &         ' MDSREADFIELD_GL: illegal value for arrType'
# Line 187  C (This is a place-holder for the active Line 206  C (This is a place-holder for the active
206              call MDS_BYTESWAPR8( sNx, r8seg )              call MDS_BYTESWAPR8( sNx, r8seg )
207  #endif  #endif
208              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
209               call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .TRUE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
210              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
211               call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .TRUE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
212              else              else
213               write(msgbuf,'(a)')               write(msgbuf,'(a)')
214       &         ' MDSREADFIELD_GL: illegal value for arrType'       &         ' MDSREADFIELD_GL: illegal value for arrType'
# Line 236  C     ---------------------------------- Line 255  C     ----------------------------------
255  C=======================================================================  C=======================================================================
256    
257  C=======================================================================  C=======================================================================
258        SUBROUTINE MDSWRITEFIELD_GL(        SUBROUTINE MDSWRITEFIELD_3D_GL(
259       I   fName,       I   fName,
260       I   filePrec,       I   filePrec,
261       I   arrType,       I   arrType,
# Line 295  C Routine arguments Line 314  C Routine arguments
314        integer nNz        integer nNz
315  cph(  cph(
316  cph      Real arr(*)  cph      Real arr(*)
317        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nNz)        _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
318  cph)  cph)
319        integer irecord        integer irecord
320        integer myIter        integer myIter
# Line 361  C If we are writing to a tiled MDS file Line 380  C If we are writing to a tiled MDS file
380            fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
381           endif           endif
382          if (fileIsOpen) then          if (fileIsOpen) then
383           do k=1,nNz           do k=1,Nr
384            do j=1,sNy            do j=1,sNy
385               do ii=1,sNx               do ii=1,sNx
386                  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)
387               enddo               enddo
388              iG = 0              iG = 0
389              jG = 0              jG = 0
390              irec=j + sNy*(k-1) + sNy*nNz*(irecord-1)              irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
391             if (filePrec .eq. precFloat32) then             if (filePrec .eq. precFloat32) then
392              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
393               call MDS_SEG4toRS( j,bi,bj,k,nNz, r4seg, .FALSE., arr )               call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
394              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
395               call MDS_SEG4toRL( j,bi,bj,k,nNz, r4seg, .FALSE., arr )               call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
396              else              else
397               write(msgbuf,'(a)')               write(msgbuf,'(a)')
398       &         ' 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 405  C If we are writing to a tiled MDS file
405              write(dUnit,rec=irec) r4seg              write(dUnit,rec=irec) r4seg
406             elseif (filePrec .eq. precFloat64) then             elseif (filePrec .eq. precFloat64) then
407              if (arrType .eq. 'RS') then              if (arrType .eq. 'RS') then
408               call MDS_SEG8toRS( j,bi,bj,k,nNz, r8seg, .FALSE., arr )               call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
409              elseif (arrType .eq. 'RL') then              elseif (arrType .eq. 'RL') then
410               call MDS_SEG8toRL( j,bi,bj,k,nNz, r8seg, .FALSE., arr )               call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
411              else              else
412               write(msgbuf,'(a)')               write(msgbuf,'(a)')
413       &         ' 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 454  C Create meta-file for each tile if we a
454           dimList(2,3)=1           dimList(2,3)=1
455           dimList(3,3)=Nr           dimList(3,3)=Nr
456           ndims=3           ndims=3
457           if (nNz .EQ. 1) ndims=2           if (Nr .EQ. 1) ndims=2
458           call MDSWRITEMETA( metaFName, dataFName,           call MDSWRITEMETA( metaFName, dataFName,
459       &     filePrec, ndims, dimList, irecord, myIter, mythid )       &     filePrec, ndims, dimList, irecord, myIter, mythid )
460  C End of bi,bj loops  C End of bi,bj loops
# Line 448  C End of ip,jp loops Line 467  C End of ip,jp loops
467    
468        _END_MASTER( myThid )        _END_MASTER( myThid )
469    
470    C     ------------------------------------------------------------------
471          return
472          end
473    C=======================================================================
474    
475    C=======================================================================
476          SUBROUTINE MDSREADFIELD_2D_GL(
477         I   fName,
478         I   filePrec,
479         I   arrType,
480         I   nNz,
481         O   arr_gl,
482         I   irecord,
483         I   myThid )
484    C
485    C Arguments:
486    C
487    C fName         string  base name for file to read
488    C filePrec      integer number of bits per word in file (32 or 64)
489    C arrType       char(2) declaration of "arr": either "RS" or "RL"
490    C nNz           integer size of third dimension: normally either 1 or Nr
491    C arr           RS/RL   array to read into, arr(:,:,nNz,:,:)
492    C irecord       integer record number to read
493    C myThid        integer thread identifier
494    C
495    C MDSREADFIELD first checks to see if the file "fName" exists, then
496    C if the file "fName.data" exists and finally the tiled files of the
497    C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
498    C read because it is difficult to parse files in fortran.
499    C The precision of the file is decsribed by filePrec, set either
500    C to floatPrec32 or floatPrec64. The precision or declaration of
501    C the array argument must be consistently described by the char*(2)
502    C string arrType, either "RS" or "RL". nNz allows for both 2-D and
503    C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
504    C nNz=Nr implies a 3-D model field. irecord is the record number
505    C to be read and must be >= 1. The file data is stored in
506    C arr *but* the overlaps are *not* updated. ie. An exchange must
507    C be called. This is because the routine is sometimes called from
508    C within a MASTER_THID region.
509    C
510    C Created: 03/16/99 adcroft@mit.edu
511    
512          implicit none
513    C Global variables / common blocks
514    #include "SIZE.h"
515    #include "EEPARAMS.h"
516    #include "PARAMS.h"
517    
518    C Routine arguments
519          character*(*) fName
520          integer filePrec
521          character*(2) arrType
522          integer nNz, nLocz
523          parameter (nLocz = 1)
524          _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
525          integer irecord
526          integer myThid
527    C Functions
528          integer ILNBLNK
529          integer MDS_RECLEN
530    C Local variables
531          character*(80) dataFName
532          integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
533          logical exst
534          _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
535          Real*4 r4seg(sNx)
536          Real*8 r8seg(sNx)
537          logical globalFile,fileIsOpen
538          integer length_of_rec
539          character*(max_len_mbuf) msgbuf
540    C     ------------------------------------------------------------------
541    
542    C Only do I/O if I am the master thread
543          _BEGIN_MASTER( myThid )
544    
545    C Record number must be >= 1
546          if (irecord .LT. 1) then
547           write(msgbuf,'(a,i9.8)')
548         &   ' MDSREADFIELD_GL: argument irecord = ',irecord
549           call print_message( msgbuf, standardmessageunit,
550         &                     SQUEEZE_RIGHT , mythid)
551           write(msgbuf,'(a)')
552         &   ' MDSREADFIELD_GL: Invalid value for irecord'
553           call print_error( msgbuf, mythid )
554           stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
555          endif
556    
557    C Assume nothing
558          globalFile = .FALSE.
559          fileIsOpen = .FALSE.
560          IL=ILNBLNK( fName )
561    
562    C Assign a free unit number as the I/O channel for this routine
563          call MDSFINDUNIT( dUnit, mythid )
564    
565    C Check first for global file with simple name (ie. fName)
566          dataFName = fName
567          inquire( file=dataFname, exist=exst )
568          if (exst) then
569           write(msgbuf,'(a,a)')
570         &   ' MDSREADFIELD: opening global file: ',dataFName
571           call print_message( msgbuf, standardmessageunit,
572         &                     SQUEEZE_RIGHT , mythid)
573          endif
574    
575    C If negative check for global file with MDS name (ie. fName.data)
576          if (.NOT. globalFile) then
577           write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
578           inquire( file=dataFname, exist=exst )
579           if (exst) then
580            write(msgbuf,'(a,a)')
581         &    ' MDSREADFIELD_GL: opening global file: ',dataFName
582            call print_message( msgbuf, standardmessageunit,
583         &                      SQUEEZE_RIGHT , mythid)
584            globalFile = .TRUE.
585           endif
586          endif
587    C Loop over all processors    
588          do jp=1,nPy
589          do ip=1,nPx
590    C Loop over all tiles
591          do bj=1,nSy
592          do bi=1,nSx
593    C If we are reading from a tiled MDS file then we open each one here
594            if (.NOT. globalFile) then
595             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
596             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
597             write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
598         &              fName(1:IL),'.',iG,'.',jG,'.data'
599             inquire( file=dataFname, exist=exst )
600    C Of course, we only open the file if the tile is "active"
601    C (This is a place-holder for the active/passive mechanism
602             if (exst) then
603              if ( debugLevel .GE. debLevA ) then
604               write(msgbuf,'(a,a)')
605         &      ' MDSREADFIELD_GL: opening file: ',dataFName
606               call print_message( msgbuf, standardmessageunit,
607         &                        SQUEEZE_RIGHT , mythid)
608              endif
609              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
610              open( dUnit, file=dataFName, status='old',
611         &        access='direct', recl=length_of_rec )
612              fileIsOpen=.TRUE.
613             else
614              fileIsOpen=.FALSE.
615              write(msgbuf,'(a,a)')
616         &      ' MDSREADFIELD_GL: filename: ',dataFName
617              call print_message( msgbuf, standardmessageunit,
618         &                        SQUEEZE_RIGHT , mythid)
619              call print_error( msgbuf, mythid )
620              write(msgbuf,'(a)')
621         &      ' MDSREADFIELD_GL: File does not exist'
622              call print_message( msgbuf, standardmessageunit,
623         &                        SQUEEZE_RIGHT , mythid)
624              call print_error( msgbuf, mythid )
625              stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
626             endif
627            endif
628    
629            if (fileIsOpen) then
630             do k=1,nLocz
631              do j=1,sNy
632                iG = 0
633                jG = 0
634                irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
635               if (filePrec .eq. precFloat32) then
636                read(dUnit,rec=irec) r4seg
637    #ifdef _BYTESWAPIO
638                call MDS_BYTESWAPR4( sNx, r4seg )
639    #endif
640                if (arrType .eq. 'RS') then
641                 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
642                elseif (arrType .eq. 'RL') then
643                 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
644                else
645                 write(msgbuf,'(a)')
646         &         ' MDSREADFIELD_GL: illegal value for arrType'
647                 call print_error( msgbuf, mythid )
648                 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
649                endif
650               elseif (filePrec .eq. precFloat64) then
651                read(dUnit,rec=irec) r8seg
652    #ifdef _BYTESWAPIO
653                call MDS_BYTESWAPR8( sNx, r8seg )
654    #endif
655                if (arrType .eq. 'RS') then
656                 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
657                elseif (arrType .eq. 'RL') then
658                 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
659                else
660                 write(msgbuf,'(a)')
661         &         ' MDSREADFIELD_GL: illegal value for arrType'
662                 call print_error( msgbuf, mythid )
663                 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
664                endif
665               else
666                write(msgbuf,'(a)')
667         &        ' MDSREADFIELD_GL: illegal value for filePrec'
668                call print_error( msgbuf, mythid )
669                stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
670               endif
671           do ii=1,sNx
672            arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
673           enddo
674    
675    C End of j loop
676              enddo
677    C End of k loop
678             enddo
679             if (.NOT. globalFile) then
680              close( dUnit )
681              fileIsOpen = .FALSE.
682             endif
683            endif
684    C End of bi,bj loops
685           enddo
686          enddo
687    C End of ip,jp loops
688           enddo
689          enddo
690    
691    C If global file was opened then close it
692          if (fileIsOpen .AND. globalFile) then
693           close( dUnit )
694           fileIsOpen = .FALSE.
695          endif
696    
697          _END_MASTER( myThid )
698    
699    C     ------------------------------------------------------------------
700          return
701          end
702    C=======================================================================
703    
704    C=======================================================================
705          SUBROUTINE MDSWRITEFIELD_2D_GL(
706         I   fName,
707         I   filePrec,
708         I   arrType,
709         I   nNz,
710         I   arr_gl,
711         I   irecord,
712         I   myIter,
713         I   myThid )
714    C
715    C Arguments:
716    C
717    C fName         string  base name for file to written
718    C filePrec      integer number of bits per word in file (32 or 64)
719    C arrType       char(2) declaration of "arr": either "RS" or "RL"
720    C nNz           integer size of third dimension: normally either 1 or Nr
721    C arr           RS/RL   array to write, arr(:,:,nNz,:,:)
722    C irecord       integer record number to read
723    C myIter        integer time step number
724    C myThid        integer thread identifier
725    C
726    C MDSWRITEFIELD creates either a file of the form "fName.data" and
727    C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
728    C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
729    C "fName.xxx.yyy.meta". A meta-file is always created.
730    C Currently, the meta-files are not read because it is difficult
731    C to parse files in fortran. We should read meta information before
732    C adding records to an existing multi-record file.
733    C The precision of the file is decsribed by filePrec, set either
734    C to floatPrec32 or floatPrec64. The precision or declaration of
735    C the array argument must be consistently described by the char*(2)
736    C string arrType, either "RS" or "RL". nNz allows for both 2-D and
737    C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
738    C nNz=Nr implies a 3-D model field. irecord is the record number
739    C to be read and must be >= 1. NOTE: It is currently assumed that
740    C the highest record number in the file was the last record written.
741    C Nor is there a consistency check between the routine arguments and file.
742    C ie. if your write record 2 after record 4 the meta information
743    C will record the number of records to be 2. This, again, is because
744    C we have read the meta information. To be fixed.
745    C
746    C Created: 03/16/99 adcroft@mit.edu
747    C
748    C Changed: 05/31/00 heimbach@mit.edu
749    C          open(dUnit, ..., status='old', ... -> status='unknown'
750    
751          implicit none
752    C Global variables / common blocks
753    #include "SIZE.h"
754    #include "EEPARAMS.h"
755    #include "PARAMS.h"
756    
757    C Routine arguments
758          character*(*) fName
759          integer filePrec
760          character*(2) arrType
761          integer nNz, nLocz
762          parameter (nLocz = 1)
763    cph(
764    cph      Real arr(*)
765          _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
766    cph)
767          integer irecord
768          integer myIter
769          integer myThid
770    C Functions
771          integer ILNBLNK
772          integer MDS_RECLEN
773    C Local variables
774          character*(80) dataFName,metaFName
775          integer ip,jp,iG,jG,irec,bi,bj,ii,j,k,dUnit,IL
776          Real*4 r4seg(sNx)
777          Real*8 r8seg(sNx)
778          _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
779          integer dimList(3,3),ndims
780          integer length_of_rec
781          logical fileIsOpen
782          character*(max_len_mbuf) msgbuf
783    C     ------------------------------------------------------------------
784    
785    C Only do I/O if I am the master thread
786          _BEGIN_MASTER( myThid )
787    
788    C Record number must be >= 1
789          if (irecord .LT. 1) then
790           write(msgbuf,'(a,i9.8)')
791         &   ' MDSWRITEFIELD_GL: argument irecord = ',irecord
792           call print_message( msgbuf, standardmessageunit,
793         &                     SQUEEZE_RIGHT , mythid)
794           write(msgbuf,'(a)')
795         &   ' MDSWRITEFIELD_GL: invalid value for irecord'
796           call print_error( msgbuf, mythid )
797           stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
798          endif
799    
800    C Assume nothing
801          fileIsOpen=.FALSE.
802          IL=ILNBLNK( fName )
803    
804    C Assign a free unit number as the I/O channel for this routine
805          call MDSFINDUNIT( dUnit, mythid )
806    
807    
808    C Loop over all processors    
809          do jp=1,nPy
810          do ip=1,nPx
811    C Loop over all tiles
812          do bj=1,nSy
813           do bi=1,nSx
814    C If we are writing to a tiled MDS file then we open each one here
815             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
816             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
817             write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
818         &              fName(1:IL),'.',iG,'.',jG,'.data'
819             if (irecord .EQ. 1) then
820              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
821              open( dUnit, file=dataFName, status=_NEW_STATUS,
822         &       access='direct', recl=length_of_rec )
823              fileIsOpen=.TRUE.
824             else
825              length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
826              open( dUnit, file=dataFName, status=_OLD_STATUS,
827         &       access='direct', recl=length_of_rec )
828              fileIsOpen=.TRUE.
829             endif
830            if (fileIsOpen) then
831             do k=1,nLocz
832              do j=1,sNy
833                 do ii=1,sNx
834                    arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
835                 enddo
836                iG = 0
837                jG = 0
838                irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
839               if (filePrec .eq. precFloat32) then
840                if (arrType .eq. 'RS') then
841                 call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
842                elseif (arrType .eq. 'RL') then
843                 call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
844                else
845                 write(msgbuf,'(a)')
846         &         ' MDSWRITEFIELD_GL: illegal value for arrType'
847                 call print_error( msgbuf, mythid )
848                 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
849                endif
850    #ifdef _BYTESWAPIO
851                call MDS_BYTESWAPR4( sNx, r4seg )
852    #endif
853                write(dUnit,rec=irec) r4seg
854               elseif (filePrec .eq. precFloat64) then
855                if (arrType .eq. 'RS') then
856                 call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
857                elseif (arrType .eq. 'RL') then
858                 call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
859                else
860                 write(msgbuf,'(a)')
861         &         ' MDSWRITEFIELD_GL: illegal value for arrType'
862                 call print_error( msgbuf, mythid )
863                 stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
864                endif
865    #ifdef _BYTESWAPIO
866                call MDS_BYTESWAPR8( sNx, r8seg )
867  #endif  #endif
868                write(dUnit,rec=irec) r8seg
869               else
870                write(msgbuf,'(a)')
871         &        ' MDSWRITEFIELD_GL: illegal value for filePrec'
872                call print_error( msgbuf, mythid )
873                stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
874               endif
875    C End of j loop
876              enddo
877    C End of k loop
878             enddo
879            else
880             write(msgbuf,'(a)')
881         &     ' MDSWRITEFIELD_GL: I should never get to this point'
882             call print_error( msgbuf, mythid )
883             stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
884            endif
885    C If we were writing to a tiled MDS file then we close it here
886            if (fileIsOpen) then
887             close( dUnit )
888             fileIsOpen = .FALSE.
889            endif
890    C Create meta-file for each tile if we are tiling
891             iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
892             jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
893             write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
894         &              fName(1:IL),'.',iG,'.',jG,'.meta'
895             dimList(1,1)=Nx
896             dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
897             dimList(3,1)=((ip-1)*nSx+bi)*sNx
898             dimList(1,2)=Ny
899             dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
900             dimList(3,2)=((jp-1)*nSy+bj)*sNy
901             dimList(1,3)=Nr
902             dimList(2,3)=1
903             dimList(3,3)=Nr
904             ndims=3
905             if (nLocz .EQ. 1) ndims=2
906             call MDSWRITEMETA( metaFName, dataFName,
907         &     filePrec, ndims, dimList, irecord, myIter, mythid )
908    C End of bi,bj loops
909           enddo
910          enddo
911    C End of ip,jp loops
912           enddo
913          enddo
914    
915    
916          _END_MASTER( myThid )
917    
918  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
919        return        return
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6
  ViewVC Help
Powered by ViewVC 1.1.22