/[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.2 - (show annotations) (download)
Thu Feb 7 20:00:09 2002 UTC (22 years, 3 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint46n_post, checkpoint47e_post, checkpoint44e_post, checkpoint46l_post, checkpoint46g_pre, checkpoint47c_post, checkpoint50c_post, checkpoint46f_post, checkpoint48e_post, checkpoint50c_pre, checkpoint44f_post, checkpoint46b_post, checkpoint48i_post, checkpoint46l_pre, chkpt44d_post, checkpoint51, checkpoint50, checkpoint50d_post, checkpoint50b_pre, checkpoint44e_pre, checkpoint48b_post, checkpoint48c_pre, checkpoint47d_pre, checkpoint47a_post, checkpoint48d_pre, checkpoint47i_post, checkpoint47d_post, checkpoint46d_pre, checkpoint48d_post, checkpoint48f_post, checkpoint45d_post, checkpoint46j_pre, checkpoint44h_pre, checkpoint48h_post, checkpoint51b_pre, checkpoint46a_post, checkpoint47g_post, checkpoint46j_post, checkpoint46k_post, chkpt44c_pre, checkpoint48a_post, checkpoint45a_post, checkpoint50f_post, checkpoint50a_post, checkpoint50f_pre, checkpoint47j_post, branch-exfmods-tag, checkpoint44g_post, checkpoint46e_pre, checkpoint48c_post, checkpoint45b_post, checkpoint46b_pre, release1_final_v1, checkpoint51b_post, checkpoint46c_pre, checkpoint46, checkpoint47b_post, checkpoint44b_post, checkpoint46h_pre, checkpoint46m_post, checkpoint46a_pre, checkpoint50g_post, checkpoint45c_post, checkpoint44h_post, checkpoint46g_post, checkpoint50h_post, checkpoint50e_pre, checkpoint50i_post, checkpoint47f_post, checkpoint50e_post, checkpoint46i_post, checkpoint46c_post, checkpoint50d_pre, checkpoint46e_post, checkpoint47, checkpoint45, checkpoint48, checkpoint49, checkpoint46h_post, chkpt44c_post, checkpoint48g_post, checkpoint47h_post, checkpoint44f_pre, checkpoint46d_post, checkpoint50b_post, checkpoint51a_post
Branch point for: branch-exfmods-curt, release1_final, release1
Changes since 1.1: +915 -0 lines
o merge of relevant stuff from the ecco-branch:
  - genmake: removed $S64 overwrite for case SunOS
  - pkg/exf: update and corrections for field swapping and obcs
  - pkg/ecco: parameter lists for the_model_main, the_main_loop
              harmonized between ECCO and MITgcm
  - pkg/autodiff: added flow directives for obcs, mdsio_gl_slice
                  updated checkpointing_lev... lists for obcs
  - model/src: minor changes in forward_step, plot_field
               added directive for divided adjoint in the_main_loop
  - pkg/mdsio: added mdsio_gl_slice

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

  ViewVC Help
Powered by ViewVC 1.1.22