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

Annotation of /MITgcm/pkg/mdsio/mdsio_writevec_loc.F

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

Revision 1.5 - (hide annotations) (download)
Tue Sep 1 19:08:27 2009 UTC (14 years, 9 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint62, checkpoint62c, checkpoint62b, checkpoint62a, checkpoint62g, checkpoint62f, checkpoint62e, checkpoint62d, checkpoint62k, checkpoint62j, checkpoint62i, checkpoint62h, checkpoint62o, checkpoint62n, checkpoint62m, checkpoint62l, checkpoint62p, checkpoint61v, checkpoint61w, checkpoint61z, checkpoint61x, checkpoint61y
Changes since 1.4: +25 -23 lines 
rework MDS-IO high level S/R interface:
 To avoid mixing type (RS/RL) of input/output array argument,
 replace single mixed array with a pair of each type (RS/Rl).
1 jmc 1.5 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_writevec_loc.F,v 1.4 2009/08/02 20:42:43 jmc Exp $
2 jmc 1.1 C $Name: $
3    
4     #include "MDSIO_OPTIONS.h"
5    
6 jmc 1.3 CBOP
7     C !ROUTINE: MDS_WRITEVEC_LOC
8     C !INTERFACE:
9 jmc 1.2 SUBROUTINE MDS_WRITEVEC_LOC(
10 jmc 1.1 I fName,
11     I filePrec,
12 jmc 1.3 U ioUnit,
13 jmc 1.2 I arrType,
14 jmc 1.5 I nSize,
15     I fldRL, fldRS,
16 jmc 1.1 I bi, bj,
17     I irecord,
18     I myIter,
19     I myThid )
20 jmc 1.2
21 jmc 1.3 C !DESCRIPTION:
22 jmc 1.1 C Arguments:
23     C
24 jmc 1.3 C fName string :: base name for file to written
25 jmc 1.2 C filePrec integer :: number of bits per word in file (32 or 64)
26 jmc 1.3 C ioUnit integer :: fortran file IO unit
27 jmc 1.5 C nSize integer :: number of elements from input array "fldRL/RS" to be written
28     C arrType char(2) :: which array (fldRL/RS) to write, either "RL" or "RS"
29     C fldRL ( RL ) :: array to write if arrType="RL", fldRL(nSize)
30     C fldRS ( RS ) :: array to write if arrType="RS", fldRS(nSize)
31 jmc 1.2 C bi,bj integer :: tile indices (if tiled array) or 0,0 if not a tiled array
32 jmc 1.3 C irecord integer :: record number to WRITE =|irecord|
33 jmc 1.2 C myIter integer :: time step number
34     C myThid integer :: my Thread Id number
35 jmc 1.1 C
36 jmc 1.3 C MDS_WRITEVEC_LOC according to ioUnit:
37     C ioUnit = 0 : open file, write and close the file (return ioUnit=0).
38     C ioUnit =-1 : open file, write and leave it open (return IO unit in ioUnit)
39     C ioUnit > 0 : assume file "ioUnit" is open, and write to it.
40     C MDS_WRITEVEC_LOC writes either to a file of the form "fName.data" and
41 jmc 1.5 C "fName.meta" if bi=bj=0. Otherwise it writes to MDS tiled files of the
42 jmc 1.1 C form "fName.xxx.yyy.data" and "fName.xxx.yyy.meta".
43 jmc 1.3 C If irecord>0, a meta-file is created (skipped if irecord<0).
44 jmc 1.5 C The precision of the file is described by filePrec, set either
45 jmc 1.1 C to floatPrec32 or floatPrec64.
46 jmc 1.3 C |irecord|=iRec is the record number to be written and must be >=1.
47 jmc 1.1
48 jmc 1.3 C !USES:
49 jmc 1.1 IMPLICIT NONE
50 jmc 1.3
51 jmc 1.1 C Global variables / common blocks
52     #include "SIZE.h"
53     #include "EEPARAMS.h"
54     #include "PARAMS.h"
55    
56 jmc 1.3 C !INPUT/OUTPUT PARAMETERS:
57 jmc 1.1 CHARACTER*(*) fName
58 jmc 1.3 INTEGER ioUnit
59 jmc 1.1 INTEGER filePrec
60 jmc 1.2 CHARACTER*(2) arrType
61 jmc 1.5 INTEGER nSize
62     _RL fldRL(*)
63     _RS fldRS(*)
64 jmc 1.1 INTEGER bi,bj
65     INTEGER irecord
66     INTEGER myIter
67     INTEGER myThid
68 jmc 1.3
69     C !FUNCTIONS:
70 jmc 1.1 INTEGER ILNBLNK
71     INTEGER MDS_RECLEN
72 jmc 1.2 EXTERNAL ILNBLNK
73     EXTERNAL MDS_RECLEN
74 jmc 1.3
75     C !LOCAL VARIABLES:
76 jmc 1.1 CHARACTER*(MAX_LEN_FNAM) dataFName, metaFName, pfName
77     CHARACTER*(MAX_LEN_MBUF) msgBuf
78     LOGICAL fileIsOpen
79 jmc 1.5 INTEGER iG,jG,iRec,dUnit,IL,pIL
80 jmc 1.2 INTEGER dimList(3,3), nDims, map2gl(2)
81 jmc 1.1 INTEGER length_of_rec
82     INTEGER loc_size
83     PARAMETER( loc_size = Nx+Ny+Nr )
84 jmc 1.5 Real*4 r4seg(loc_size)
85     Real*8 r8seg(loc_size)
86 jmc 1.4 _RL dummyRL(1)
87     CHARACTER*8 blank8c
88 jmc 1.3 CEOP
89 jmc 1.1
90 jmc 1.4 DATA dummyRL(1) / 0. _d 0 /
91     DATA blank8c / ' ' /
92     DATA map2gl / 0, 1 /
93 jmc 1.2
94 jmc 1.3 C We write a non-tiled array (bi=bj=0) only 1 time (if ProcId=0):
95     IF ( myProcId.EQ.0 .OR. bi.NE.0 .OR. bj.NE.0 ) THEN
96    
97 jmc 1.1 C Only DO I/O IF I am the master thread
98 jmc 1.3 _BEGIN_MASTER( myThid )
99    
100     C Assume nothing
101     fileIsOpen = .FALSE.
102     IL = ILNBLNK( fName )
103     iRec = ABS(irecord)
104 jmc 1.1
105     C Record number must be >= 1
106 jmc 1.3 IF ( iRec.LT.1 ) THEN
107 jmc 1.2 WRITE(msgBuf,'(A,I9)')
108     & ' MDS_WRITEVEC_LOC: argument irecord = ',irecord
109 jmc 1.1 CALL PRINT_ERROR( msgBuf, myThid )
110     WRITE(msgBuf,'(A)')
111 jmc 1.2 & ' MDS_WRITEVEC_LOC: invalid value for irecord'
112 jmc 1.1 CALL PRINT_ERROR( msgBuf, myThid )
113 jmc 1.2 STOP 'ABNORMAL END: S/R MDS_WRITEVEC_LOC'
114 jmc 1.1 ENDIF
115    
116 jmc 1.2 C Check buffer size
117 jmc 1.5 IF ( nSize.GT.loc_size ) THEN
118 jmc 1.2 WRITE(msgBuf,'(3A)')
119     & ' MDS_WRITEVEC_LOC: writing to file "', fName(1:IL), '":'
120     CALL PRINT_ERROR( msgBuf, myThid )
121     WRITE(msgBuf,'(A,I9)')
122 jmc 1.5 & ' MDS_WRITEVEC_LOC: dim of array to write=', nSize
123 jmc 1.2 CALL PRINT_ERROR( msgBuf, myThid )
124     WRITE(msgBuf,'(A,I9)')
125     & ' MDS_WRITEVEC_LOC: exceeds buffer size=', loc_size
126     CALL PRINT_ERROR( msgBuf, myThid )
127     STOP 'ABNORMAL END: S/R MDS_WRITEVEC_LOC'
128     ENDIF
129 jmc 1.1
130     C Assign special directory
131     IF ( mdsioLocalDir .NE. ' ' ) THEN
132     pIL = ILNBLNK( mdsioLocalDir )
133     WRITE(pFname,'(2A)') mdsioLocalDir(1:pIL), fName(1:IL)
134     pIL = IL + pIL
135     ELSE
136     WRITE(pFname,'(A)') fName(1:IL)
137     pIL = IL
138     ENDIF
139    
140 jmc 1.3 IF ( ioUnit.GT.0 ) THEN
141     C- Assume file Unit is already open with correct Rec-Length & Precision
142     fileIsOpen = .TRUE.
143     dUnit = ioUnit
144     ELSE
145     C- Need to open file IO unit with File-name, Rec-Length & Precision
146    
147     C Assign a free unit number as the I/O channel for this routine
148     CALL MDSFINDUNIT( dUnit, myThid )
149 jmc 1.1
150 jmc 1.3 C-- Set the file Name:
151     IF ( bi.EQ.0 .AND. bj.EQ.0 ) THEN
152     C- we are writing a non-tiled array (bi=bj=0):
153     WRITE(dataFname,'(2A)') fName(1:IL),'.data'
154     ELSE
155     C- we are writing a tiled array (bi>0,bj>0):
156     iG=bi+(myXGlobalLo-1)/sNx
157     jG=bj+(myYGlobalLo-1)/sNy
158     WRITE(dataFname,'(2A,I3.3,A,I3.3,A)')
159 jmc 1.1 & pfName(1:pIL),'.',iG,'.',jG,'.data'
160 jmc 1.3 ENDIF
161 jmc 1.1
162 jmc 1.3 C-- Open the file:
163 jmc 1.5 length_of_rec=MDS_RECLEN( filePrec, nSize, myThid )
164 jmc 1.3 IF (iRec .EQ. 1) THEN
165     OPEN( dUnit, file=dataFName, status=_NEW_STATUS,
166     & access='direct', recl=length_of_rec )
167     fileIsOpen=.TRUE.
168     ELSE
169     OPEN( dUnit, file=dataFName, status=_OLD_STATUS,
170     & access='direct', recl=length_of_rec )
171     fileIsOpen=.TRUE.
172     ENDIF
173     IF ( debugLevel.GE.debLevB ) THEN
174     WRITE(msgBuf,'(2A)')
175 jmc 1.2 & ' MDS_WRITEVEC_LOC: open file: ',dataFname(1:pIL+13)
176 jmc 1.3 CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
177     & SQUEEZE_RIGHT , 1)
178     ENDIF
179     C- End if block: File Unit is already open / Need to open it
180 jmc 1.1 ENDIF
181    
182     IF (fileIsOpen) THEN
183 jmc 1.2 IF ( arrType.EQ.'RS' ) THEN
184 jmc 1.5 CALL MDS_WR_REC_RS( fldRS, r4seg, r8seg,
185     I filePrec, dUnit, iRec, nSize, myThid )
186 jmc 1.2 ELSEIF ( arrType.EQ.'RL' ) THEN
187 jmc 1.5 CALL MDS_WR_REC_RL( fldRL, r4seg, r8seg,
188     I filePrec, dUnit, iRec, nSize, myThid )
189 jmc 1.1 ELSE
190     WRITE(msgBuf,'(A)')
191 jmc 1.2 & ' MDS_WRITEVEC_LOC: illegal value for arrType'
192 jmc 1.1 CALL PRINT_ERROR( msgBuf, myThid )
193 jmc 1.2 STOP 'ABNORMAL END: S/R MDS_WRITEVEC_LOC'
194 jmc 1.1 ENDIF
195     ELSE
196     WRITE(msgBuf,'(A)')
197 jmc 1.2 & ' MDS_WRITEVEC_LOC: should never reach this point'
198 jmc 1.1 CALL PRINT_ERROR( msgBuf, myThid )
199 jmc 1.2 STOP 'ABNORMAL END: S/R MDS_WRITEVEC_LOC'
200 jmc 1.1 ENDIF
201    
202     C If we were writing to a tiled MDS file then we close it here
203 jmc 1.3 IF ( fileIsOpen .AND. ioUnit.EQ.0 ) THEN
204 jmc 1.1 CLOSE( dUnit )
205     fileIsOpen = .FALSE.
206     ENDIF
207 jmc 1.3 IF ( ioUnit.EQ.-1 ) ioUnit = dUnit
208 jmc 1.1
209 jmc 1.3 IF ( irecord.GT.0 ) THEN
210 jmc 1.1 C Create meta-file for each tile IF we are tiling
211 jmc 1.3 IF ( bi.EQ.0 .AND. bj.EQ.0 ) THEN
212     C-- we are writing a non-tiled array (bi=bj=0):
213     WRITE(metaFname,'(2A)') fName(1:IL),'.meta'
214     dimList(1,1)=1
215     dimList(2,1)=1
216     dimList(3,1)=1
217     dimList(1,2)=1
218     dimList(2,2)=1
219     dimList(3,2)=1
220     ELSE
221     C-- we are writing a tiled array (bi>0,bj>0):
222     iG=bi+(myXGlobalLo-1)/sNx
223     jG=bj+(myYGlobalLo-1)/sNy
224     WRITE(metaFname,'(2A,I3.3,A,I3.3,A)')
225 jmc 1.1 & pfName(1:pIL),'.',iG,'.',jG,'.meta'
226 jmc 1.3 dimList(1,1)=nSx*nPx
227     dimList(2,1)=iG
228     dimList(3,1)=iG
229     dimList(1,2)=nSy*nPy
230     dimList(2,2)=jG
231     dimList(3,2)=jG
232     ENDIF
233 jmc 1.5 dimList(1,3)=nSize
234 jmc 1.3 dimList(2,3)=1
235 jmc 1.5 dimList(3,3)=nSize
236 jmc 1.3 nDims=3
237 jmc 1.5 IF ( nSize.EQ.1 ) nDims=2
238 jmc 1.3 CALL MDS_WRITE_META(
239 jmc 1.2 I metaFName, dataFName, the_run_name, ' ',
240 jmc 1.4 I filePrec, nDims, dimList, map2gl, 0, blank8c,
241     I 0, dummyRL, iRec, myIter, myThid )
242 jmc 1.3 ENDIF
243 jmc 1.1
244 jmc 1.3 _END_MASTER( myThid )
245 jmc 1.1 ENDIF
246    
247     RETURN
248     END
  ViewVC Help
Powered by ViewVC 1.1.22