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