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