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

Contents of /MITgcm/pkg/mdsio/mdsio_gl_slice.F

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


Revision 1.10 - (show annotations) (download)
Tue Sep 1 18:49:26 2009 UTC (14 years, 8 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint62, checkpoint61v, checkpoint61w, checkpoint61z, checkpoint61x, checkpoint61y
Changes since 1.9: +78 -78 lines
disabled without ALLOW_AUTODIFF defined ; remove tab ; update some comments ;

1 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_gl_slice.F,v 1.9 2005/11/05 01:05:14 jmc Exp $
2 C $Name: $
3
4 #include "MDSIO_OPTIONS.h"
5
6 C-- File mdsio_gl_slice.F: Routines to handle mid-level I/O interface.
7 C-- Contents
8 C-- o MDSREADFIELD_XZ_GL
9 C-- o MDSREADFIELD_YZ_GL
10 C-- o MDSWRITEFIELD_XZ_GL
11 C-- o MDSWRITEFIELD_YZ_GL
12
13 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
14
15 SUBROUTINE MDSREADFIELD_XZ_GL(
16 I fName,
17 I filePrec,
18 I arrType,
19 I nNz,
20 O arr_gl,
21 I irecord,
22 I myThid )
23 C
24 C Arguments:
25 C
26 C fName string :: base name for file to read
27 C filePrec integer :: number of bits per word in file (32 or 64)
28 C arrType char(2) :: declaration of "arr": either "RS" or "RL"
29 C nNz integer :: size of third dimension: normally either 1 or Nr
30 C arr RS/RL :: array to read into, arr(:,:,nNz,:,:)
31 C irecord integer :: record number to read
32 C myThid integer :: thread identifier
33 C
34 C MDSREADFIELD first checks to see if the file "fName" exists, then
35 C if the file "fName.data" exists and finally the tiled files of the
36 C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
37 C read because it is difficult to parse files in fortran.
38 C The precision of the file is decsribed by filePrec, set either
39 C to floatPrec32 or floatPrec64. The precision or declaration of
40 C the array argument must be consistently described by the char*(2)
41 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
42 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
43 C nNz=Nr implies a 3-D model field. irecord is the record number
44 C to be read and must be >= 1. The file data is stored in
45 C arr *but* the overlaps are *not* updated. ie. An exchange must
46 C be called. This is because the routine is sometimes called from
47 C within a MASTER_THID region.
48 C
49 C Created: 03/16/99 adcroft@mit.edu
50
51 implicit none
52 C Global variables / common blocks
53 #include "SIZE.h"
54 #include "EEPARAMS.h"
55 #include "PARAMS.h"
56
57 C Routine arguments
58 character*(*) fName
59 integer filePrec
60 character*(2) arrType
61 integer nNz
62 _RL arr_gl(sNx,nSx,nPx,nSy,nPy,Nr)
63 integer irecord
64 integer myThid
65
66 #ifdef ALLOW_AUTODIFF
67 C Functions
68 integer ILNBLNK
69 integer MDS_RECLEN
70 C Local variables
71 character*(MAX_LEN_FNAM) dataFName
72 integer ip,jp,iG,jG,irec,bi,bj,ii,k,dUnit,IL
73 logical exst
74 _RL arr(1-oLx:sNx+oLx,Nr,nSx,nSy)
75 Real*4 r4seg(sNx)
76 Real*8 r8seg(sNx)
77 logical globalFile,fileIsOpen
78 integer length_of_rec
79 character*(max_len_mbuf) msgbuf
80 C ------------------------------------------------------------------
81
82 C Only do I/O if I am the master thread
83 _BEGIN_MASTER( myThid )
84
85 C Record number must be >= 1
86 if (irecord .LT. 1) then
87 write(msgbuf,'(a,i9.8)')
88 & ' MDSREADFIELD_GL: argument irecord = ',irecord
89 call print_message( msgbuf, standardmessageunit,
90 & SQUEEZE_RIGHT , mythid)
91 write(msgbuf,'(a)')
92 & ' MDSREADFIELD_GL: Invalid value for irecord'
93 call print_error( msgbuf, mythid )
94 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
95 endif
96
97 C Assume nothing
98 globalFile = .FALSE.
99 fileIsOpen = .FALSE.
100 IL=ILNBLNK( fName )
101
102 C Assign a free unit number as the I/O channel for this routine
103 call MDSFINDUNIT( dUnit, mythid )
104
105 C Check first for global file with simple name (ie. fName)
106 dataFName = fName
107 inquire( file=dataFname, exist=exst )
108 if (exst) then
109 write(msgbuf,'(a,a)')
110 & ' MDSREADFIELD: opening global file: ',dataFName(1:IL)
111 call print_message( msgbuf, standardmessageunit,
112 & SQUEEZE_RIGHT , mythid)
113 endif
114
115 C If negative check for global file with MDS name (ie. fName.data)
116 if (.NOT. globalFile) then
117 write(dataFname,'(2a)') fName(1:IL),'.data'
118 inquire( file=dataFname, exist=exst )
119 if (exst) then
120 write(msgbuf,'(a,a)')
121 & ' MDSREADFIELD_XZ_GL: opening global file: ',dataFName(1:IL+5)
122 call print_message( msgbuf, standardmessageunit,
123 & SQUEEZE_RIGHT , mythid)
124 globalFile = .TRUE.
125 endif
126 endif
127
128 C Loop over all processors
129 do jp=1,nPy
130 do ip=1,nPx
131 C Loop over all tiles
132 do bj=1,nSy
133 do bi=1,nSx
134 C If we are reading from a tiled MDS file then we open each one here
135 if (.NOT. globalFile) then
136 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
137 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
138 write(dataFname,'(2a,i3.3,a,i3.3,a)')
139 & fName(1:IL),'.',iG,'.',jG,'.data'
140 inquire( file=dataFname, exist=exst )
141 C Of course, we only open the file if the tile is "active"
142 C (This is a place-holder for the active/passive mechanism
143 if (exst) then
144 if ( debugLevel .GE. debLevA ) then
145 write(msgbuf,'(a,a)')
146 & ' MDSREADFIELD_XZ_GL: opening file: ',dataFName(1:IL+13)
147 call print_message( msgbuf, standardmessageunit,
148 & SQUEEZE_RIGHT , mythid)
149 endif
150 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
151 open( dUnit, file=dataFName, status='old',
152 & access='direct', recl=length_of_rec )
153 fileIsOpen=.TRUE.
154 else
155 fileIsOpen=.FALSE.
156 write(msgbuf,'(a,a)')
157 & ' MDSREADFIELD_XZ_GL: filename: ',dataFName(1:IL+13)
158 call print_message( msgbuf, standardmessageunit,
159 & SQUEEZE_RIGHT , mythid)
160 write(msgbuf,'(a)')
161 & ' MDSREADFIELD_XZ_GL: File does not exist'
162 call print_error( msgbuf, mythid )
163 stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
164 endif
165 endif
166
167 if (fileIsOpen) then
168 do k=1,Nr
169 iG = 0
170 jG = 0
171 irec=k + Nr*(irecord-1)
172 if (filePrec .eq. precFloat32) then
173 read(dUnit,rec=irec) r4seg
174 #ifdef _BYTESWAPIO
175 call MDS_BYTESWAPR4( sNx, r4seg )
176 #endif
177 if (arrType .eq. 'RS') then
178 call MDS_SEG4toRS_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r4seg,arr)
179 elseif (arrType .eq. 'RL') then
180 call MDS_SEG4toRL_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r4seg,arr)
181 else
182 write(msgbuf,'(a)')
183 & ' MDSREADFIELD_XZ_GL: illegal value for arrType'
184 call print_error( msgbuf, mythid )
185 stop 'ABNORMAL END: S/R MDSREADFIELD_XZ_GL'
186 endif
187 elseif (filePrec .eq. precFloat64) then
188 read(dUnit,rec=irec) r8seg
189 #ifdef _BYTESWAPIO
190 call MDS_BYTESWAPR8( sNx, r8seg )
191 #endif
192 if (arrType .eq. 'RS') then
193 call MDS_SEG8toRS_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r8seg,arr)
194 elseif (arrType .eq. 'RL') then
195 call MDS_SEG8toRL_2D(sNx,oLx,nNz,bi,bj,k,.TRUE.,r8seg,arr)
196 else
197 write(msgbuf,'(a)')
198 & ' MDSREADFIELD_XZ_GL: illegal value for arrType'
199 call print_error( msgbuf, mythid )
200 stop 'ABNORMAL END: S/R MDSREADFIELD_XZ_GL'
201 endif
202 else
203 write(msgbuf,'(a)')
204 & ' MDSREADFIELD_XZ_GL: illegal value for filePrec'
205 call print_error( msgbuf, mythid )
206 stop 'ABNORMAL END: S/R MDSREADFIELD_XZ_GL'
207 endif
208 do ii=1,sNx
209 arr_gl(ii,bi,ip,bj,jp,k)=arr(ii,k,bi,bj)
210 enddo
211
212 C End of k loop
213 enddo
214 if (.NOT. globalFile) then
215 close( dUnit )
216 fileIsOpen = .FALSE.
217 endif
218 endif
219 C End of bi,bj loops
220 enddo
221 enddo
222 C End of ip,jp loops
223 enddo
224 enddo
225
226 C If global file was opened then close it
227 if (fileIsOpen .AND. globalFile) then
228 close( dUnit )
229 fileIsOpen = .FALSE.
230 endif
231
232 _END_MASTER( myThid )
233
234 #else /* ALLOW_AUTODIFF */
235 STOP 'ABNORMAL END: S/R MDSREADFIELD_XZ_GL is empty'
236 #endif /* ALLOW_AUTODIFF */
237 C ------------------------------------------------------------------
238 RETURN
239 END
240
241 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
242
243 SUBROUTINE MDSREADFIELD_YZ_GL(
244 I fName,
245 I filePrec,
246 I arrType,
247 I nNz,
248 O arr_gl,
249 I irecord,
250 I myThid )
251
252 C Arguments:
253 C
254 C fName string :: base name for file to read
255 C filePrec integer :: number of bits per word in file (32 or 64)
256 C arrType char(2) :: declaration of "arr": either "RS" or "RL"
257 C nNz integer :: size of third dimension: normally either 1 or Nr
258 C arr RS/RL :: array to read into, arr(:,:,nNz,:,:)
259 C irecord integer :: record number to read
260 C myThid integer :: thread identifier
261 C
262 C MDSREADFIELD first checks to see if the file "fName" exists, then
263 C if the file "fName.data" exists and finally the tiled files of the
264 C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
265 C read because it is difficult to parse files in fortran.
266 C The precision of the file is decsribed by filePrec, set either
267 C to floatPrec32 or floatPrec64. The precision or declaration of
268 C the array argument must be consistently described by the char*(2)
269 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
270 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
271 C nNz=Nr implies a 3-D model field. irecord is the record number
272 C to be read and must be >= 1. The file data is stored in
273 C arr *but* the overlaps are *not* updated. ie. An exchange must
274 C be called. This is because the routine is sometimes called from
275 C within a MASTER_THID region.
276 C
277 C Created: 03/16/99 adcroft@mit.edu
278
279 implicit none
280 C Global variables / common blocks
281 #include "SIZE.h"
282 #include "EEPARAMS.h"
283 #include "PARAMS.h"
284
285 C Routine arguments
286 character*(*) fName
287 integer filePrec
288 character*(2) arrType
289 integer nNz
290 _RL arr_gl(nSx,nPx,sNy,nSy,nPy,Nr)
291 integer irecord
292 integer myThid
293
294 #ifdef ALLOW_AUTODIFF
295 C Functions
296 integer ILNBLNK
297 integer MDS_RECLEN
298 C Local variables
299 character*(MAX_LEN_FNAM) dataFName
300 integer ip,jp,iG,jG,irec,bi,bj,jj,k,dUnit,IL
301 logical exst
302 _RL arr(1-oLy:sNy+oLy,Nr,nSx,nSy)
303 Real*4 r4seg(sNy)
304 Real*8 r8seg(sNy)
305 logical globalFile,fileIsOpen
306 integer length_of_rec
307 character*(max_len_mbuf) msgbuf
308 C ------------------------------------------------------------------
309
310 C Only do I/O if I am the master thread
311 _BEGIN_MASTER( myThid )
312
313 C Record number must be >= 1
314 if (irecord .LT. 1) then
315 write(msgbuf,'(a,i9.8)')
316 & ' MDSREADFIELD_YZ_GL: argument irecord = ',irecord
317 call print_message( msgbuf, standardmessageunit,
318 & SQUEEZE_RIGHT , mythid)
319 write(msgbuf,'(a)')
320 & ' MDSREADFIELD_YZ_GL: Invalid value for irecord'
321 call print_error( msgbuf, mythid )
322 stop 'ABNORMAL END: S/R MDSREADFIELD_YZ_GL'
323 endif
324
325 C Assume nothing
326 globalFile = .FALSE.
327 fileIsOpen = .FALSE.
328 IL=ILNBLNK( fName )
329
330 C Assign a free unit number as the I/O channel for this routine
331 call MDSFINDUNIT( dUnit, mythid )
332
333 C Check first for global file with simple name (ie. fName)
334 dataFName = fName
335 inquire( file=dataFname, exist=exst )
336 if (exst) then
337 write(msgbuf,'(a,a)')
338 & ' MDSREADFIELD_YZ: opening global file: ',dataFName(1:IL)
339 call print_message( msgbuf, standardmessageunit,
340 & SQUEEZE_RIGHT , mythid)
341 endif
342
343 C If negative check for global file with MDS name (ie. fName.data)
344 if (.NOT. globalFile) then
345 write(dataFname,'(2a)') fName(1:IL),'.data'
346 inquire( file=dataFname, exist=exst )
347 if (exst) then
348 write(msgbuf,'(a,a)')
349 & ' MDSREADFIELD_YZ_GL: opening global file: ',dataFName(1:IL+5)
350 call print_message( msgbuf, standardmessageunit,
351 & SQUEEZE_RIGHT , mythid)
352 globalFile = .TRUE.
353 endif
354 endif
355 C Loop over all processors
356 do jp=1,nPy
357 do ip=1,nPx
358 C Loop over all tiles
359 do bj=1,nSy
360 do bi=1,nSx
361 C If we are reading from a tiled MDS file then we open each one here
362 if (.NOT. globalFile) then
363 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
364 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
365 write(dataFname,'(2a,i3.3,a,i3.3,a)')
366 & fName(1:IL),'.',iG,'.',jG,'.data'
367 inquire( file=dataFname, exist=exst )
368 C Of course, we only open the file if the tile is "active"
369 C (This is a place-holder for the active/passive mechanism
370 if (exst) then
371 if ( debugLevel .GE. debLevA ) then
372 write(msgbuf,'(a,a)')
373 & ' MDSREADFIELD_YZ_GL: opening file: ',dataFName(1:IL+13)
374 call print_message( msgbuf, standardmessageunit,
375 & SQUEEZE_RIGHT , mythid)
376 endif
377 length_of_rec=MDS_RECLEN( filePrec, sNy, mythid )
378 open( dUnit, file=dataFName, status='old',
379 & access='direct', recl=length_of_rec )
380 fileIsOpen=.TRUE.
381 else
382 fileIsOpen=.FALSE.
383 write(msgbuf,'(a,a)')
384 & ' MDSREADFIELD_YZ_GL: filename: ',dataFName(1:IL+13)
385 call print_message( msgbuf, standardmessageunit,
386 & SQUEEZE_RIGHT , mythid)
387 write(msgbuf,'(a)')
388 & ' MDSREADFIELD_YZ_GL: File does not exist'
389 call print_error( msgbuf, mythid )
390 stop 'ABNORMAL END: S/R MDSREADFIELD_YZ_GL'
391 endif
392 endif
393
394 if (fileIsOpen) then
395 do k=1,Nr
396 iG = 0
397 jG = 0
398 irec=k + Nr*(irecord-1)
399 if (filePrec .eq. precFloat32) then
400 read(dUnit,rec=irec) r4seg
401 #ifdef _BYTESWAPIO
402 call MDS_BYTESWAPR4( sNy, r4seg )
403 #endif
404 if (arrType .eq. 'RS') then
405 call MDS_SEG4toRS_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r4seg,arr)
406 elseif (arrType .eq. 'RL') then
407 call MDS_SEG4toRL_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r4seg,arr)
408 else
409 write(msgbuf,'(a)')
410 & ' MDSREADFIELD_YZ_GL: illegal value for arrType'
411 call print_error( msgbuf, mythid )
412 stop 'ABNORMAL END: S/R MDSREADFIELD_YZ_GL'
413 endif
414 elseif (filePrec .eq. precFloat64) then
415 read(dUnit,rec=irec) r8seg
416 #ifdef _BYTESWAPIO
417 call MDS_BYTESWAPR8( sNy, r8seg )
418 #endif
419 if (arrType .eq. 'RS') then
420 call MDS_SEG8toRS_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r8seg,arr)
421 elseif (arrType .eq. 'RL') then
422 call MDS_SEG8toRL_2D(sNy,oLy,nNz,bi,bj,k,.TRUE.,r8seg,arr)
423 else
424 write(msgbuf,'(a)')
425 & ' MDSREADFIELD_YZ_GL: illegal value for arrType'
426 call print_error( msgbuf, mythid )
427 stop 'ABNORMAL END: S/R MDSREADFIELD_YZ_GL'
428 endif
429 else
430 write(msgbuf,'(a)')
431 & ' MDSREADFIELD_YZ_GL: illegal value for filePrec'
432 call print_error( msgbuf, mythid )
433 stop 'ABNORMAL END: S/R MDSREADFIELD_YZ_GL'
434 endif
435 do jj=1,sNy
436 arr_gl(bi,ip,jj,bj,jp,k)=arr(jj,k,bi,bj)
437 enddo
438
439 C End of k loop
440 enddo
441 if (.NOT. globalFile) then
442 close( dUnit )
443 fileIsOpen = .FALSE.
444 endif
445 endif
446 C End of bi,bj loops
447 enddo
448 enddo
449 C End of ip,jp loops
450 enddo
451 enddo
452
453 C If global file was opened then close it
454 if (fileIsOpen .AND. globalFile) then
455 close( dUnit )
456 fileIsOpen = .FALSE.
457 endif
458
459 _END_MASTER( myThid )
460
461 #else /* ALLOW_AUTODIFF */
462 STOP 'ABNORMAL END: S/R MDSREADFIELD_YZ_GL is empty'
463 #endif /* ALLOW_AUTODIFF */
464 C ------------------------------------------------------------------
465 RETURN
466 END
467
468 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
469
470 SUBROUTINE MDSWRITEFIELD_XZ_GL(
471 I fName,
472 I filePrec,
473 I arrType,
474 I nNz,
475 I arr_gl,
476 I irecord,
477 I myIter,
478 I myThid )
479 C
480 C Arguments:
481 C
482 C fName string :: base name for file to write
483 C filePrec integer :: number of bits per word in file (32 or 64)
484 C arrType char(2) :: declaration of "arr": either "RS" or "RL"
485 C nNz integer :: size of third dimension: normally either 1 or Nr
486 C arr RS/RL :: array to write, arr(:,:,nNz,:,:)
487 C irecord integer :: record number to write
488 C myIter integer :: time step number
489 C myThid integer :: thread identifier
490 C
491 C MDSWRITEFIELD creates either a file of the form "fName.data" and
492 C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
493 C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
494 C "fName.xxx.yyy.meta". A meta-file is always created.
495 C Currently, the meta-files are not read because it is difficult
496 C to parse files in fortran. We should read meta information before
497 C adding records to an existing multi-record file.
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. NOTE: It is currently assumed that
505 C the highest record number in the file was the last record written.
506 C Nor is there a consistency check between the routine arguments and file.
507 C ie. if your write record 2 after record 4 the meta information
508 C will record the number of records to be 2. This, again, is because
509 C we have read the meta information. To be fixed.
510 C
511 C Created: 03/16/99 adcroft@mit.edu
512 C
513 C Changed: 05/31/00 heimbach@mit.edu
514 C open(dUnit, ..., status='old', ... -> status='unknown'
515
516 implicit none
517 C Global variables / common blocks
518 #include "SIZE.h"
519 #include "EEPARAMS.h"
520 #include "PARAMS.h"
521
522 C Routine arguments
523 character*(*) fName
524 integer filePrec
525 character*(2) arrType
526 integer nNz
527 cph(
528 cph Real arr(*)
529 _RL arr_gl(sNx,nSx,nPx,nSy,nPy,Nr)
530 cph)
531 integer irecord
532 integer myIter
533 integer myThid
534
535 #ifdef ALLOW_AUTODIFF
536 C Functions
537 integer ILNBLNK
538 integer MDS_RECLEN
539 C Local variables
540 character*(MAX_LEN_FNAM) dataFName,metaFName
541 integer ip,jp,iG,jG,irec,bi,bj,ii,k,dUnit,IL
542 Real*4 r4seg(sNx)
543 Real*8 r8seg(sNx)
544 _RL arr(1-oLx:sNx+oLx,Nr,nSx,nSy)
545 integer dimList(3,3),ndims
546 integer length_of_rec
547 logical fileIsOpen
548 character*(max_len_mbuf) msgbuf
549 C ------------------------------------------------------------------
550
551 C Only do I/O if I am the master thread
552 _BEGIN_MASTER( myThid )
553
554 C Record number must be >= 1
555 if (irecord .LT. 1) then
556 write(msgbuf,'(a,i9.8)')
557 & ' MDSWRITEFIELD_XZ_GL: argument irecord = ',irecord
558 call print_message( msgbuf, standardmessageunit,
559 & SQUEEZE_RIGHT , mythid)
560 write(msgbuf,'(a)')
561 & ' MDSWRITEFIELD_XZ_GL: invalid value for irecord'
562 call print_error( msgbuf, mythid )
563 stop 'ABNORMAL END: S/R MDSWRITEFIELD_XZ_GL'
564 endif
565
566 C Assume nothing
567 fileIsOpen=.FALSE.
568 IL=ILNBLNK( fName )
569
570 C Assign a free unit number as the I/O channel for this routine
571 call MDSFINDUNIT( dUnit, mythid )
572
573
574 C Loop over all processors
575 do jp=1,nPy
576 do ip=1,nPx
577 C Loop over all tiles
578 do bj=1,nSy
579 do bi=1,nSx
580 C If we are writing to a tiled MDS file then we open each one here
581 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
582 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
583 write(dataFname,'(2a,i3.3,a,i3.3,a)')
584 & fName(1:IL),'.',iG,'.',jG,'.data'
585 if (irecord .EQ. 1) then
586 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
587 open( dUnit, file=dataFName, status=_NEW_STATUS,
588 & access='direct', recl=length_of_rec )
589 fileIsOpen=.TRUE.
590 else
591 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
592 open( dUnit, file=dataFName, status=_OLD_STATUS,
593 & access='direct', recl=length_of_rec )
594 fileIsOpen=.TRUE.
595 endif
596 if (fileIsOpen) then
597 do k=1,Nr
598 do ii=1,sNx
599 arr(ii,k,bi,bj)=arr_gl(ii,bi,ip,bj,jp,k)
600 enddo
601 iG = 0
602 jG = 0
603 irec=k + Nr*(irecord-1)
604 if (filePrec .eq. precFloat32) then
605 if (arrType .eq. 'RS') then
606 call MDS_SEG4toRS_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r4seg,arr)
607 elseif (arrType .eq. 'RL') then
608 call MDS_SEG4toRL_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r4seg,arr)
609 else
610 write(msgbuf,'(a)')
611 & ' MDSWRITEFIELD_XZ_GL: illegal value for arrType'
612 call print_error( msgbuf, mythid )
613 stop 'ABNORMAL END: S/R MDSWRITEFIELD_XZ_GL'
614 endif
615 #ifdef _BYTESWAPIO
616 call MDS_BYTESWAPR4( sNx, r4seg )
617 #endif
618 write(dUnit,rec=irec) r4seg
619 elseif (filePrec .eq. precFloat64) then
620 if (arrType .eq. 'RS') then
621 call MDS_SEG8toRS_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r8seg,arr)
622 elseif (arrType .eq. 'RL') then
623 call MDS_SEG8toRL_2D(sNx,oLx,nNz,bi,bj,k,.FALSE.,r8seg,arr)
624 else
625 write(msgbuf,'(a)')
626 & ' MDSWRITEFIELD_XZ_GL: illegal value for arrType'
627 call print_error( msgbuf, mythid )
628 stop 'ABNORMAL END: S/R MDSWRITEFIELD_XZ_GL'
629 endif
630 #ifdef _BYTESWAPIO
631 call MDS_BYTESWAPR8( sNx, r8seg )
632 #endif
633 write(dUnit,rec=irec) r8seg
634 else
635 write(msgbuf,'(a)')
636 & ' MDSWRITEFIELD_XZ_GL: illegal value for filePrec'
637 call print_error( msgbuf, mythid )
638 stop 'ABNORMAL END: S/R MDSWRITEFIELD_XZ_GL'
639 endif
640 C End of k loop
641 enddo
642 else
643 write(msgbuf,'(a)')
644 & ' MDSWRITEFIELD_XZ_GL: I should never get to this point'
645 call print_error( msgbuf, mythid )
646 stop 'ABNORMAL END: S/R MDSWRITEFIELD_XZ_GL'
647 endif
648 C If we were writing to a tiled MDS file then we close it here
649 if (fileIsOpen) then
650 close( dUnit )
651 fileIsOpen = .FALSE.
652 endif
653 C Create meta-file for each tile if we are tiling
654 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
655 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
656 write(metaFname,'(2a,i3.3,a,i3.3,a)')
657 & fName(1:IL),'.',iG,'.',jG,'.meta'
658 dimList(1,1)=Nx
659 dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
660 dimList(3,1)=((ip-1)*nSx+bi)*sNx
661 dimList(1,2)=nSy*nPy
662 dimList(2,2)=(jp-1)*nSy+bj
663 dimList(3,2)= jp*nSy+bj
664 dimList(1,3)=Nr
665 dimList(2,3)=1
666 dimList(3,3)=Nr
667 ndims=3
668 if (Nr .EQ. 1) ndims=2
669 call MDSWRITEMETA( metaFName, dataFName,
670 & filePrec, ndims, dimList, irecord, myIter, mythid )
671 C End of bi,bj loops
672 enddo
673 enddo
674 C End of ip,jp loops
675 enddo
676 enddo
677
678 _END_MASTER( myThid )
679
680 #else /* ALLOW_AUTODIFF */
681 STOP 'ABNORMAL END: S/R MDSWRITEFIELD_XZ_GL is empty'
682 #endif /* ALLOW_AUTODIFF */
683 C ------------------------------------------------------------------
684 RETURN
685 END
686
687 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
688
689 SUBROUTINE MDSWRITEFIELD_YZ_GL(
690 I fName,
691 I filePrec,
692 I arrType,
693 I nNz,
694 I arr_gl,
695 I irecord,
696 I myIter,
697 I myThid )
698 C
699 C Arguments:
700 C
701 C fName string :: base name for file to write
702 C filePrec integer :: number of bits per word in file (32 or 64)
703 C arrType char(2) :: declaration of "arr": either "RS" or "RL"
704 C nNz integer :: size of third dimension: normally either 1 or Nr
705 C arr RS/RL :: array to write, arr(:,:,nNz,:,:)
706 C irecord integer :: record number to write
707 C myIter integer :: time step number
708 C myThid integer :: thread identifier
709 C
710 C MDSWRITEFIELD creates either a file of the form "fName.data" and
711 C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
712 C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
713 C "fName.xxx.yyy.meta". A meta-file is always created.
714 C Currently, the meta-files are not read because it is difficult
715 C to parse files in fortran. We should read meta information before
716 C adding records to an existing multi-record file.
717 C The precision of the file is decsribed by filePrec, set either
718 C to floatPrec32 or floatPrec64. The precision or declaration of
719 C the array argument must be consistently described by the char*(2)
720 C string arrType, either "RS" or "RL". nNz allows for both 2-D and
721 C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
722 C nNz=Nr implies a 3-D model field. irecord is the record number
723 C to be read and must be >= 1. NOTE: It is currently assumed that
724 C the highest record number in the file was the last record written.
725 C Nor is there a consistency check between the routine arguments and file.
726 C ie. if your write record 2 after record 4 the meta information
727 C will record the number of records to be 2. This, again, is because
728 C we have read the meta information. To be fixed.
729 C
730 C Created: 03/16/99 adcroft@mit.edu
731 C
732 C Changed: 05/31/00 heimbach@mit.edu
733 C open(dUnit, ..., status='old', ... -> status='unknown'
734
735 implicit none
736 C Global variables / common blocks
737 #include "SIZE.h"
738 #include "EEPARAMS.h"
739 #include "PARAMS.h"
740
741 C Routine arguments
742 character*(*) fName
743 integer filePrec
744 character*(2) arrType
745 integer nNz
746 cph(
747 cph Real arr(*)
748 _RL arr_gl(nSx,nPx,sNy,nSy,nPy,Nr)
749 cph)
750 integer irecord
751 integer myIter
752 integer myThid
753
754 #ifdef ALLOW_AUTODIFF
755 C Functions
756 integer ILNBLNK
757 integer MDS_RECLEN
758 C Local variables
759 character*(MAX_LEN_FNAM) dataFName,metaFName
760 integer ip,jp,iG,jG,irec,bi,bj,jj,k,dUnit,IL
761 Real*4 r4seg(sNy)
762 Real*8 r8seg(sNy)
763 _RL arr(1-oLy:sNy+oLy,Nr,nSx,nSy)
764 integer dimList(3,3),ndims
765 integer length_of_rec
766 logical fileIsOpen
767 character*(max_len_mbuf) msgbuf
768 C ------------------------------------------------------------------
769
770 C Only do I/O if I am the master thread
771 _BEGIN_MASTER( myThid )
772
773 C Record number must be >= 1
774 if (irecord .LT. 1) then
775 write(msgbuf,'(a,i9.8)')
776 & ' MDSWRITEFIELD_YZ_GL: argument irecord = ',irecord
777 call print_message( msgbuf, standardmessageunit,
778 & SQUEEZE_RIGHT , mythid)
779 write(msgbuf,'(a)')
780 & ' MDSWRITEFIELD_YZ_GL: invalid value for irecord'
781 call print_error( msgbuf, mythid )
782 stop 'ABNORMAL END: S/R MDSWRITEFIELD_YZ_GL'
783 endif
784
785 C Assume nothing
786 fileIsOpen=.FALSE.
787 IL=ILNBLNK( fName )
788
789 C Assign a free unit number as the I/O channel for this routine
790 call MDSFINDUNIT( dUnit, mythid )
791
792
793 C Loop over all processors
794 do jp=1,nPy
795 do ip=1,nPx
796 C Loop over all tiles
797 do bj=1,nSy
798 do bi=1,nSx
799 C If we are writing to a tiled MDS file then we open each one here
800 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
801 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
802 write(dataFname,'(2a,i3.3,a,i3.3,a)')
803 & fName(1:IL),'.',iG,'.',jG,'.data'
804 if (irecord .EQ. 1) then
805 length_of_rec=MDS_RECLEN( filePrec, sNy, mythid )
806 open( dUnit, file=dataFName, status=_NEW_STATUS,
807 & access='direct', recl=length_of_rec )
808 fileIsOpen=.TRUE.
809 else
810 length_of_rec=MDS_RECLEN( filePrec, sNy, mythid )
811 open( dUnit, file=dataFName, status=_OLD_STATUS,
812 & access='direct', recl=length_of_rec )
813 fileIsOpen=.TRUE.
814 endif
815 if (fileIsOpen) then
816 do k=1,Nr
817 do jj=1,sNy
818 arr(jj,k,bi,bj)=arr_gl(bi,ip,jj,bj,jp,k)
819 enddo
820 iG = 0
821 jG = 0
822 irec=k + Nr*(irecord-1)
823 if (filePrec .eq. precFloat32) then
824 if (arrType .eq. 'RS') then
825 call MDS_SEG4toRS_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r4seg,arr)
826 elseif (arrType .eq. 'RL') then
827 call MDS_SEG4toRL_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r4seg,arr)
828 else
829 write(msgbuf,'(a)')
830 & ' MDSWRITEFIELD_YZ_GL: illegal value for arrType'
831 call print_error( msgbuf, mythid )
832 stop 'ABNORMAL END: S/R MDSWRITEFIELD_YZ_GL'
833 endif
834 #ifdef _BYTESWAPIO
835 call MDS_BYTESWAPR4( sNy, r4seg )
836 #endif
837 write(dUnit,rec=irec) r4seg
838 elseif (filePrec .eq. precFloat64) then
839 if (arrType .eq. 'RS') then
840 call MDS_SEG8toRS_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r8seg,arr)
841 elseif (arrType .eq. 'RL') then
842 call MDS_SEG8toRL_2D(sNy,oLy,nNz,bi,bj,k,.FALSE.,r8seg,arr)
843 else
844 write(msgbuf,'(a)')
845 & ' MDSWRITEFIELD_YZ_GL: illegal value for arrType'
846 call print_error( msgbuf, mythid )
847 stop 'ABNORMAL END: S/R MDSWRITEFIELD_YZ_GL'
848 endif
849 #ifdef _BYTESWAPIO
850 call MDS_BYTESWAPR8( sNy, r8seg )
851 #endif
852 write(dUnit,rec=irec) r8seg
853 else
854 write(msgbuf,'(a)')
855 & ' MDSWRITEFIELD_YZ_GL: illegal value for filePrec'
856 call print_error( msgbuf, mythid )
857 stop 'ABNORMAL END: S/R MDSWRITEFIELD_YZ_GL'
858 endif
859 C End of k loop
860 enddo
861 else
862 write(msgbuf,'(a)')
863 & ' MDSWRITEFIELD_YZ_GL: I should never get to this point'
864 call print_error( msgbuf, mythid )
865 stop 'ABNORMAL END: S/R MDSWRITEFIELD_YZ_GL'
866 endif
867 C If we were writing to a tiled MDS file then we close it here
868 if (fileIsOpen) then
869 close( dUnit )
870 fileIsOpen = .FALSE.
871 endif
872 C Create meta-file for each tile if we are tiling
873 iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
874 jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
875 write(metaFname,'(2a,i3.3,a,i3.3,a)')
876 & fName(1:IL),'.',iG,'.',jG,'.meta'
877 dimList(1,1)=Nx
878 dimList(2,1)=(ip-1)*nSx+bi
879 dimList(3,1)=ip*nSx+bi
880 dimList(1,2)=Ny
881 dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
882 dimList(3,2)=((jp-1)*nSy+bj)*sNy
883 dimList(1,3)=Nr
884 dimList(2,3)=1
885 dimList(3,3)=Nr
886 ndims=3
887 if (Nr .EQ. 1) ndims=2
888 call MDSWRITEMETA( metaFName, dataFName,
889 & filePrec, ndims, dimList, irecord, myIter, mythid )
890 C End of bi,bj loops
891 enddo
892 enddo
893 C End of ip,jp loops
894 enddo
895 enddo
896
897 _END_MASTER( myThid )
898
899 #else /* ALLOW_AUTODIFF */
900 STOP 'ABNORMAL END: S/R MDSWRITEFIELD_YZ_GL is empty'
901 #endif /* ALLOW_AUTODIFF */
902 C ------------------------------------------------------------------
903 RETURN
904 END

  ViewVC Help
Powered by ViewVC 1.1.22