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