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

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

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

Revision 1.2 - (hide annotations) (download)
Thu Feb 7 20:00:09 2002 UTC (22 years, 4 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 heimbach 1.2 #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