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

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

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

Revision 1.11 - (hide annotations) (download)
Fri Aug 19 18:01:29 2005 UTC (19 years, 10 months ago) by heimbach
Branch: MAIN
Changes since 1.10: +2 -3 lines 
Fixed [data,meta]FName initialization.
1 heimbach 1.11 C $Header: /u/gcmpack/MITgcm/pkg/mdsio/mdsio_gl.F,v 1.10 2005/02/18 21:41:44 heimbach Exp $
2 adcroft 1.1
3 edhill 1.4 #include "MDSIO_OPTIONS.h"
4 heimbach 1.2
5     C The five "public" routines supplied here are:
6     C
7     C MDSREADFIELD - read model field from direct access global or tiled MDS file
8     C MDSWRITEFIELD - write model field to direct access global or tiled MDS file
9     C MDSFINDUNIT - returns an available (unused) I/O channel
10     C MDSREADVECTOR - read vector from direct access global or tiled MDS file
11     C MDSWRITEVECTOR - write vector to direct access global or tiled MDS file
12     C
13     C all other routines are "private" to these utilities and ought
14     C not be accessed directly from the main code.
15     C
16     C Created: 03/16/99 adcroft@mit.edu
17     C Modified: 03/23/99 adcroft@mit.edu
18     C To work with multiple records
19     C Modified: 03/29/99 eckert@mit.edu
20     C Added arbitrary vector capability
21     C Modified: 07/27/99 eckert@mit.edu
22     C Customized for state estimation (--> active_file_control.F)
23     C this relates only to *mdsreadvector* and *mdswritevector*
24     C Modified: 07/28/99 eckert@mit.edu
25     C inserted calls to *print_message* and *print_error*
26     C
27     C To be modified to work with MITgcmuv message routines.
28 adcroft 1.1
29     C=======================================================================
30 heimbach 1.2 SUBROUTINE MDSREADFIELD_3D_GL(
31 adcroft 1.1 I fName,
32     I filePrec,
33     I arrType,
34     I nNz,
35     O arr_gl,
36     I irecord,
37     I myThid )
38     C
39     C Arguments:
40     C
41     C fName string base name for file to read
42     C filePrec integer number of bits per word in file (32 or 64)
43     C arrType char(2) declaration of "arr": either "RS" or "RL"
44     C nNz integer size of third dimension: normally either 1 or Nr
45     C arr RS/RL array to read into, arr(:,:,nNz,:,:)
46     C irecord integer record number to read
47     C myThid integer thread identifier
48     C
49     C MDSREADFIELD first checks to see if the file "fName" exists, then
50     C if the file "fName.data" exists and finally the tiled files of the
51     C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
52     C read because it is difficult to parse files in fortran.
53     C The precision of the file is decsribed by filePrec, set either
54     C to floatPrec32 or floatPrec64. The precision or declaration of
55     C the array argument must be consistently described by the char*(2)
56     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
57     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
58     C nNz=Nr implies a 3-D model field. irecord is the record number
59     C to be read and must be >= 1. The file data is stored in
60     C arr *but* the overlaps are *not* updated. ie. An exchange must
61     C be called. This is because the routine is sometimes called from
62     C within a MASTER_THID region.
63     C
64 heimbach 1.2 C Created: 03/16/99 adcroft@mit.edu
65 adcroft 1.1
66     implicit none
67     C Global variables / common blocks
68     #include "SIZE.h"
69     #include "EEPARAMS.h"
70 heimbach 1.7 #include "EESUPPORT.h"
71 adcroft 1.1 #include "PARAMS.h"
72    
73     C Routine arguments
74     character*(*) fName
75     integer filePrec
76     character*(2) arrType
77     integer nNz
78 heimbach 1.2 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
79 adcroft 1.1 integer irecord
80     integer myThid
81     C Functions
82     integer ILNBLNK
83     integer MDS_RECLEN
84     C Local variables
85     character*(80) dataFName
86 heimbach 1.10 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
87 adcroft 1.1 logical exst
88     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
89     Real*4 r4seg(sNx)
90     Real*8 r8seg(sNx)
91     logical globalFile,fileIsOpen
92     integer length_of_rec
93     character*(max_len_mbuf) msgbuf
94 heimbach 1.9 cph-usesingle(
95     integer ii,jj
96     integer x_size,y_size,iG_IO,jG_IO,npe
97     PARAMETER ( x_size = Nx )
98     PARAMETER ( y_size = Ny )
99     Real*4 xy_buffer_r4(x_size,y_size)
100     Real*8 xy_buffer_r8(x_size,y_size)
101     Real*8 global(Nx,Ny)
102     _RL local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
103     cph-usesingle)
104    
105 adcroft 1.1 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 heimbach 1.9 if ( useSingleCPUIO ) then
131    
132     #ifdef ALLOW_USE_MPI
133     IF( mpiMyId .EQ. 0 ) THEN
134     #else
135     IF ( .TRUE. ) THEN
136     #endif /* ALLOW_USE_MPI */
137    
138 adcroft 1.1 C Check first for global file with simple name (ie. fName)
139 heimbach 1.9 dataFName = fName
140     inquire( file=dataFname, exist=exst )
141     if (exst) globalFile = .TRUE.
142 adcroft 1.1
143     C If negative check for global file with MDS name (ie. fName.data)
144 heimbach 1.9 if (.NOT. globalFile) then
145     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
146     inquire( file=dataFname, exist=exst )
147     if (exst) globalFile = .TRUE.
148     endif
149    
150     C If global file is visible to process 0, then open it here.
151     C Otherwise stop program.
152     if ( globalFile) then
153     length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
154     open( dUnit, file=dataFName, status='old',
155     & access='direct', recl=length_of_rec )
156     else
157     write(msgbuf,'(2a)') ' MDSREADFIELD: filename: ',dataFName
158     call print_message( msgbuf, standardmessageunit,
159     & SQUEEZE_RIGHT , mythid)
160     call print_error( msgbuf, mythid )
161     write(msgbuf,'(a)')
162     & ' MDSREADFIELD: File does not exist'
163     call print_message( msgbuf, standardmessageunit,
164     & SQUEEZE_RIGHT , mythid)
165     call print_error( msgbuf, mythid )
166     stop 'ABNORMAL END: S/R MDSREADFIELD'
167     endif
168    
169     ENDIF
170    
171     c-- useSingleCpuIO
172     else
173     C Only do I/O if I am the master thread
174    
175     C Check first for global file with simple name (ie. fName)
176     dataFName = fName
177 adcroft 1.1 inquire( file=dataFname, exist=exst )
178     if (exst) then
179     write(msgbuf,'(a,a)')
180 heimbach 1.9 & ' MDSREADFIELD: opening global file: ',dataFName
181 adcroft 1.1 call print_message( msgbuf, standardmessageunit,
182     & SQUEEZE_RIGHT , mythid)
183     endif
184 heimbach 1.9
185     C If negative check for global file with MDS name (ie. fName.data)
186     if (.NOT. globalFile) then
187     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
188     inquire( file=dataFname, exist=exst )
189     if (exst) then
190     write(msgbuf,'(a,a)')
191     & ' MDSREADFIELD_GL: opening global file: ',dataFName
192     call print_message( msgbuf, standardmessageunit,
193     & SQUEEZE_RIGHT , mythid)
194     globalFile = .TRUE.
195     endif
196     endif
197    
198     c-- useSingleCpuIO
199 adcroft 1.1 endif
200 heimbach 1.7
201 heimbach 1.9 if ( .not. useSingleCpuIO ) then
202     if ( .not. ( globalFile ) ) then
203 heimbach 1.7
204     C If we are reading from a global file then we open it here
205     if (globalFile) then
206     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
207     open( dUnit, file=dataFName, status='old',
208     & access='direct', recl=length_of_rec )
209     fileIsOpen=.TRUE.
210     endif
211    
212 adcroft 1.1 C Loop over all processors
213     do jp=1,nPy
214     do ip=1,nPx
215     C Loop over all tiles
216     do bj=1,nSy
217     do bi=1,nSx
218     C If we are reading from a tiled MDS file then we open each one here
219     if (.NOT. globalFile) then
220     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
221     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
222     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
223     & fName(1:IL),'.',iG,'.',jG,'.data'
224     inquire( file=dataFname, exist=exst )
225     C Of course, we only open the file if the tile is "active"
226     C (This is a place-holder for the active/passive mechanism
227     if (exst) then
228 heimbach 1.3 if ( debugLevel .GE. debLevA ) then
229     write(msgbuf,'(a,a)')
230 adcroft 1.1 & ' MDSREADFIELD_GL: opening file: ',dataFName
231 heimbach 1.3 call print_message( msgbuf, standardmessageunit,
232 adcroft 1.1 & SQUEEZE_RIGHT , mythid)
233 heimbach 1.3 endif
234 adcroft 1.1 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
235     open( dUnit, file=dataFName, status='old',
236     & access='direct', recl=length_of_rec )
237     fileIsOpen=.TRUE.
238     else
239     fileIsOpen=.FALSE.
240     write(msgbuf,'(a,a)')
241     & ' MDSREADFIELD_GL: filename: ',dataFName
242     call print_message( msgbuf, standardmessageunit,
243     & SQUEEZE_RIGHT , mythid)
244 heimbach 1.6 call print_error( msgbuf, mythid )
245 adcroft 1.1 write(msgbuf,'(a)')
246     & ' MDSREADFIELD_GL: File does not exist'
247 heimbach 1.6 call print_message( msgbuf, standardmessageunit,
248     & SQUEEZE_RIGHT , mythid)
249 adcroft 1.1 call print_error( msgbuf, mythid )
250     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
251     endif
252     endif
253    
254     if (fileIsOpen) then
255 heimbach 1.2 do k=1,Nr
256 adcroft 1.1 do j=1,sNy
257 heimbach 1.7 if (globalFile) then
258     iG=bi+(ip-1)*nsx
259     jG=bj+(jp-1)*nsy
260     irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
261     & + nSx*nPx*Ny*nNz*(irecord-1)
262     else
263 adcroft 1.1 iG = 0
264     jG = 0
265 heimbach 1.2 irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
266 heimbach 1.7 endif
267 adcroft 1.1 if (filePrec .eq. precFloat32) then
268     read(dUnit,rec=irec) r4seg
269     #ifdef _BYTESWAPIO
270     call MDS_BYTESWAPR4( sNx, r4seg )
271     #endif
272     if (arrType .eq. 'RS') then
273 heimbach 1.2 call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
274 adcroft 1.1 elseif (arrType .eq. 'RL') then
275 heimbach 1.2 call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .TRUE., arr )
276 adcroft 1.1 else
277     write(msgbuf,'(a)')
278     & ' MDSREADFIELD_GL: illegal value for arrType'
279     call print_error( msgbuf, mythid )
280     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
281     endif
282     elseif (filePrec .eq. precFloat64) then
283     read(dUnit,rec=irec) r8seg
284     #ifdef _BYTESWAPIO
285     call MDS_BYTESWAPR8( sNx, r8seg )
286     #endif
287     if (arrType .eq. 'RS') then
288 heimbach 1.2 call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
289 adcroft 1.1 elseif (arrType .eq. 'RL') then
290 heimbach 1.2 call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .TRUE., arr )
291 adcroft 1.1 else
292     write(msgbuf,'(a)')
293     & ' MDSREADFIELD_GL: illegal value for arrType'
294     call print_error( msgbuf, mythid )
295     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
296     endif
297     else
298     write(msgbuf,'(a)')
299     & ' MDSREADFIELD_GL: illegal value for filePrec'
300     call print_error( msgbuf, mythid )
301     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
302     endif
303     do ii=1,sNx
304     arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
305     enddo
306    
307     C End of j loop
308     enddo
309     C End of k loop
310     enddo
311     if (.NOT. globalFile) then
312     close( dUnit )
313     fileIsOpen = .FALSE.
314     endif
315     endif
316     C End of bi,bj loops
317     enddo
318     enddo
319     C End of ip,jp loops
320     enddo
321     enddo
322    
323     C If global file was opened then close it
324     if (fileIsOpen .AND. globalFile) then
325     close( dUnit )
326     fileIsOpen = .FALSE.
327     endif
328    
329 heimbach 1.9 c end of if ( .not. ( globalFile ) ) then
330     endif
331    
332 heimbach 1.11 c else of if ( .not. ( useSingleCPUIO ) ) then
333 heimbach 1.9 else
334    
335     DO k=1,nNz
336    
337     #ifdef ALLOW_USE_MPI
338     IF( mpiMyId .EQ. 0 ) THEN
339     #else
340     IF ( .TRUE. ) THEN
341     #endif /* ALLOW_USE_MPI */
342     irec = k+nNz*(irecord-1)
343     if (filePrec .eq. precFloat32) then
344     read(dUnit,rec=irec) xy_buffer_r4
345     #ifdef _BYTESWAPIO
346     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
347     #endif
348     DO J=1,Ny
349     DO I=1,Nx
350     global(I,J) = xy_buffer_r4(I,J)
351     ENDDO
352     ENDDO
353     elseif (filePrec .eq. precFloat64) then
354     read(dUnit,rec=irec) xy_buffer_r8
355     #ifdef _BYTESWAPIO
356     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
357     #endif
358     DO J=1,Ny
359     DO I=1,Nx
360     global(I,J) = xy_buffer_r8(I,J)
361     ENDDO
362     ENDDO
363     else
364     write(msgbuf,'(a)')
365     & ' MDSREADFIELD: illegal value for filePrec'
366     call print_error( msgbuf, mythid )
367     stop 'ABNORMAL END: S/R MDSREADFIELD'
368     endif
369     ENDIF
370     DO jp=1,nPy
371     DO ip=1,nPx
372     DO bj = myByLo(myThid), myByHi(myThid)
373     DO bi = myBxLo(myThid), myBxHi(myThid)
374     DO J=1,sNy
375     JJ=((jp-1)*nSy+(bj-1))*sNy+J
376     DO I=1,sNx
377     II=((ip-1)*nSx+(bi-1))*sNx+I
378     arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
379     ENDDO
380     ENDDO
381     ENDDO
382     ENDDO
383     ENDDO
384     ENDDO
385    
386     ENDDO
387     c ENDDO k=1,nNz
388    
389     close( dUnit )
390    
391 heimbach 1.7 endif
392     c end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
393    
394 adcroft 1.1 _END_MASTER( myThid )
395    
396     C ------------------------------------------------------------------
397     return
398     end
399     C=======================================================================
400    
401     C=======================================================================
402 heimbach 1.2 SUBROUTINE MDSWRITEFIELD_3D_GL(
403 adcroft 1.1 I fName,
404     I filePrec,
405     I arrType,
406     I nNz,
407     I arr_gl,
408     I irecord,
409     I myIter,
410     I myThid )
411     C
412     C Arguments:
413     C
414     C fName string base name for file to written
415     C filePrec integer number of bits per word in file (32 or 64)
416     C arrType char(2) declaration of "arr": either "RS" or "RL"
417     C nNz integer size of third dimension: normally either 1 or Nr
418     C arr RS/RL array to write, arr(:,:,nNz,:,:)
419     C irecord integer record number to read
420     C myIter integer time step number
421     C myThid integer thread identifier
422     C
423     C MDSWRITEFIELD creates either a file of the form "fName.data" and
424     C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
425     C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
426     C "fName.xxx.yyy.meta". A meta-file is always created.
427     C Currently, the meta-files are not read because it is difficult
428     C to parse files in fortran. We should read meta information before
429     C adding records to an existing multi-record file.
430     C The precision of the file is decsribed by filePrec, set either
431     C to floatPrec32 or floatPrec64. The precision or declaration of
432     C the array argument must be consistently described by the char*(2)
433     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
434     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
435     C nNz=Nr implies a 3-D model field. irecord is the record number
436     C to be read and must be >= 1. NOTE: It is currently assumed that
437     C the highest record number in the file was the last record written.
438     C Nor is there a consistency check between the routine arguments and file.
439     C ie. if your write record 2 after record 4 the meta information
440     C will record the number of records to be 2. This, again, is because
441     C we have read the meta information. To be fixed.
442     C
443     C Created: 03/16/99 adcroft@mit.edu
444     C
445     C Changed: 05/31/00 heimbach@mit.edu
446     C open(dUnit, ..., status='old', ... -> status='unknown'
447    
448     implicit none
449     C Global variables / common blocks
450     #include "SIZE.h"
451     #include "EEPARAMS.h"
452 heimbach 1.7 #include "EESUPPORT.h"
453 adcroft 1.1 #include "PARAMS.h"
454    
455     C Routine arguments
456     character*(*) fName
457     integer filePrec
458     character*(2) arrType
459     integer nNz
460     cph(
461     cph Real arr(*)
462 heimbach 1.2 _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,Nr)
463 adcroft 1.1 cph)
464     integer irecord
465     integer myIter
466     integer myThid
467     C Functions
468     integer ILNBLNK
469     integer MDS_RECLEN
470     C Local variables
471     character*(80) dataFName,metaFName
472 heimbach 1.7 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
473 adcroft 1.1 Real*4 r4seg(sNx)
474     Real*8 r8seg(sNx)
475     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,Nr,nSx,nSy)
476     integer dimList(3,3),ndims
477     integer length_of_rec
478     logical fileIsOpen
479     character*(max_len_mbuf) msgbuf
480 heimbach 1.7 cph-usesingle(
481     integer ii,jj
482 heimbach 1.8 integer x_size,y_size,iG_IO,jG_IO,npe
483 heimbach 1.7 PARAMETER ( x_size = Nx )
484     PARAMETER ( y_size = Ny )
485     Real*4 xy_buffer_r4(x_size,y_size)
486     Real*8 xy_buffer_r8(x_size,y_size)
487     Real*8 global(Nx,Ny)
488     cph-usesingle)
489    
490 adcroft 1.1 C ------------------------------------------------------------------
491    
492     C Only do I/O if I am the master thread
493     _BEGIN_MASTER( myThid )
494    
495     C Record number must be >= 1
496     if (irecord .LT. 1) then
497     write(msgbuf,'(a,i9.8)')
498     & ' MDSWRITEFIELD_GL: argument irecord = ',irecord
499     call print_message( msgbuf, standardmessageunit,
500     & SQUEEZE_RIGHT , mythid)
501     write(msgbuf,'(a)')
502     & ' MDSWRITEFIELD_GL: invalid value for irecord'
503     call print_error( msgbuf, mythid )
504     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
505     endif
506    
507     C Assume nothing
508     fileIsOpen=.FALSE.
509     IL=ILNBLNK( fName )
510    
511     C Assign a free unit number as the I/O channel for this routine
512     call MDSFINDUNIT( dUnit, mythid )
513    
514 heimbach 1.7 cph-usesingle(
515     #ifdef ALLOW_USE_MPI
516     _END_MASTER( myThid )
517     C If option globalFile is desired but does not work or if
518     C globalFile is too slow, then try using single-CPU I/O.
519     if (useSingleCpuIO) then
520    
521     C Master thread of process 0, only, opens a global file
522     _BEGIN_MASTER( myThid )
523     IF( mpiMyId .EQ. 0 ) THEN
524     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
525     length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
526     if (irecord .EQ. 1) then
527     open( dUnit, file=dataFName, status=_NEW_STATUS,
528     & access='direct', recl=length_of_rec )
529     else
530     open( dUnit, file=dataFName, status=_OLD_STATUS,
531     & access='direct', recl=length_of_rec )
532     endif
533     ENDIF
534     _END_MASTER( myThid )
535    
536     C Gather array and write it to file, one vertical level at a time
537     DO k=1,nNz
538     C Loop over all processors
539     do jp=1,nPy
540     do ip=1,nPx
541     DO bj = myByLo(myThid), myByHi(myThid)
542     DO bi = myBxLo(myThid), myBxHi(myThid)
543     DO J=1,sNy
544     JJ=((jp-1)*nSy+(bj-1))*sNy+J
545     DO I=1,sNx
546     II=((ip-1)*nSx+(bi-1))*sNx+I
547     global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
548     ENDDO
549     ENDDO
550     ENDDO
551     ENDDO
552     enddo
553     enddo
554     _BEGIN_MASTER( myThid )
555     IF( mpiMyId .EQ. 0 ) THEN
556     irec=k+nNz*(irecord-1)
557     if (filePrec .eq. precFloat32) then
558     DO J=1,Ny
559     DO I=1,Nx
560     xy_buffer_r4(I,J) = global(I,J)
561     ENDDO
562     ENDDO
563     #ifdef _BYTESWAPIO
564     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
565     #endif
566     write(dUnit,rec=irec) xy_buffer_r4
567     elseif (filePrec .eq. precFloat64) then
568     DO J=1,Ny
569     DO I=1,Nx
570     xy_buffer_r8(I,J) = global(I,J)
571     ENDDO
572     ENDDO
573     #ifdef _BYTESWAPIO
574     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
575     #endif
576     write(dUnit,rec=irec) xy_buffer_r8
577     else
578     write(msgbuf,'(a)')
579     & ' MDSWRITEFIELD: illegal value for filePrec'
580     call print_error( msgbuf, mythid )
581     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
582     endif
583     ENDIF
584     _END_MASTER( myThid )
585     ENDDO
586    
587     C Close data-file and create meta-file
588     _BEGIN_MASTER( myThid )
589     IF( mpiMyId .EQ. 0 ) THEN
590     close( dUnit )
591     write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
592     dimList(1,1)=Nx
593     dimList(2,1)=1
594     dimList(3,1)=Nx
595     dimList(1,2)=Ny
596     dimList(2,2)=1
597     dimList(3,2)=Ny
598     dimList(1,3)=nNz
599     dimList(2,3)=1
600     dimList(3,3)=nNz
601     ndims=3
602     if (nNz .EQ. 1) ndims=2
603     call MDSWRITEMETA( metaFName, dataFName,
604     & filePrec, ndims, dimList, irecord, myIter, mythid )
605     ENDIF
606     _END_MASTER( myThid )
607     C To be safe, make other processes wait for I/O completion
608     _BARRIER
609    
610     elseif ( .NOT. useSingleCpuIO ) then
611     _BEGIN_MASTER( myThid )
612     #endif /* ALLOW_USE_MPI */
613     cph-usesingle)
614 adcroft 1.1
615     C Loop over all processors
616     do jp=1,nPy
617     do ip=1,nPx
618     C Loop over all tiles
619     do bj=1,nSy
620     do bi=1,nSx
621     C If we are writing to a tiled MDS file then we open each one here
622     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
623     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
624     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
625     & fName(1:IL),'.',iG,'.',jG,'.data'
626     if (irecord .EQ. 1) then
627     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
628     open( dUnit, file=dataFName, status=_NEW_STATUS,
629     & access='direct', recl=length_of_rec )
630     fileIsOpen=.TRUE.
631     else
632     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
633     open( dUnit, file=dataFName, status=_OLD_STATUS,
634     & access='direct', recl=length_of_rec )
635     fileIsOpen=.TRUE.
636     endif
637     if (fileIsOpen) then
638 heimbach 1.2 do k=1,Nr
639 adcroft 1.1 do j=1,sNy
640     do ii=1,sNx
641     arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
642     enddo
643     iG = 0
644     jG = 0
645 heimbach 1.2 irec=j + sNy*(k-1) + sNy*Nr*(irecord-1)
646 adcroft 1.1 if (filePrec .eq. precFloat32) then
647     if (arrType .eq. 'RS') then
648 heimbach 1.2 call MDS_SEG4toRS( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
649 adcroft 1.1 elseif (arrType .eq. 'RL') then
650 heimbach 1.2 call MDS_SEG4toRL( j,bi,bj,k,Nr, r4seg, .FALSE., arr )
651 adcroft 1.1 else
652     write(msgbuf,'(a)')
653     & ' MDSWRITEFIELD_GL: illegal value for arrType'
654     call print_error( msgbuf, mythid )
655     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
656     endif
657     #ifdef _BYTESWAPIO
658     call MDS_BYTESWAPR4( sNx, r4seg )
659     #endif
660     write(dUnit,rec=irec) r4seg
661     elseif (filePrec .eq. precFloat64) then
662     if (arrType .eq. 'RS') then
663 heimbach 1.2 call MDS_SEG8toRS( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
664 adcroft 1.1 elseif (arrType .eq. 'RL') then
665 heimbach 1.2 call MDS_SEG8toRL( j,bi,bj,k,Nr, r8seg, .FALSE., arr )
666 adcroft 1.1 else
667     write(msgbuf,'(a)')
668     & ' MDSWRITEFIELD_GL: illegal value for arrType'
669     call print_error( msgbuf, mythid )
670     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
671     endif
672     #ifdef _BYTESWAPIO
673     call MDS_BYTESWAPR8( sNx, r8seg )
674     #endif
675     write(dUnit,rec=irec) r8seg
676     else
677     write(msgbuf,'(a)')
678     & ' MDSWRITEFIELD_GL: illegal value for filePrec'
679     call print_error( msgbuf, mythid )
680     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
681     endif
682     C End of j loop
683     enddo
684     C End of k loop
685     enddo
686     else
687     write(msgbuf,'(a)')
688     & ' MDSWRITEFIELD_GL: I should never get to this point'
689     call print_error( msgbuf, mythid )
690     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
691     endif
692     C If we were writing to a tiled MDS file then we close it here
693     if (fileIsOpen) then
694     close( dUnit )
695     fileIsOpen = .FALSE.
696     endif
697     C Create meta-file for each tile if we are tiling
698     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
699     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
700     write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
701     & fName(1:IL),'.',iG,'.',jG,'.meta'
702     dimList(1,1)=Nx
703     dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
704     dimList(3,1)=((ip-1)*nSx+bi)*sNx
705     dimList(1,2)=Ny
706     dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
707     dimList(3,2)=((jp-1)*nSy+bj)*sNy
708     dimList(1,3)=Nr
709     dimList(2,3)=1
710     dimList(3,3)=Nr
711     ndims=3
712 heimbach 1.2 if (Nr .EQ. 1) ndims=2
713 adcroft 1.1 call MDSWRITEMETA( metaFName, dataFName,
714     & filePrec, ndims, dimList, irecord, myIter, mythid )
715     C End of bi,bj loops
716     enddo
717     enddo
718     C End of ip,jp loops
719     enddo
720     enddo
721    
722 heimbach 1.7 _END_MASTER( myThid )
723 adcroft 1.1
724 heimbach 1.7 cph-usesingle(
725     #ifdef ALLOW_USE_MPI
726     C endif useSingleCpuIO
727     endif
728     #endif /* ALLOW_USE_MPI */
729     cph-usesingle)
730 adcroft 1.1
731 heimbach 1.2 C ------------------------------------------------------------------
732     return
733     end
734     C=======================================================================
735    
736     C=======================================================================
737     SUBROUTINE MDSREADFIELD_2D_GL(
738     I fName,
739     I filePrec,
740     I arrType,
741     I nNz,
742     O arr_gl,
743     I irecord,
744     I myThid )
745     C
746     C Arguments:
747     C
748     C fName string base name for file to read
749     C filePrec integer number of bits per word in file (32 or 64)
750     C arrType char(2) declaration of "arr": either "RS" or "RL"
751     C nNz integer size of third dimension: normally either 1 or Nr
752     C arr RS/RL array to read into, arr(:,:,nNz,:,:)
753     C irecord integer record number to read
754     C myThid integer thread identifier
755     C
756     C MDSREADFIELD first checks to see if the file "fName" exists, then
757     C if the file "fName.data" exists and finally the tiled files of the
758     C form "fName.xxx.yyy.data" exist. Currently, the meta-files are not
759     C read because it is difficult to parse files in fortran.
760     C The precision of the file is decsribed by filePrec, set either
761     C to floatPrec32 or floatPrec64. The precision or declaration of
762     C the array argument must be consistently described by the char*(2)
763     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
764     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
765     C nNz=Nr implies a 3-D model field. irecord is the record number
766     C to be read and must be >= 1. The file data is stored in
767     C arr *but* the overlaps are *not* updated. ie. An exchange must
768     C be called. This is because the routine is sometimes called from
769     C within a MASTER_THID region.
770     C
771     C Created: 03/16/99 adcroft@mit.edu
772    
773     implicit none
774     C Global variables / common blocks
775     #include "SIZE.h"
776     #include "EEPARAMS.h"
777 heimbach 1.7 #include "EESUPPORT.h"
778 heimbach 1.2 #include "PARAMS.h"
779    
780     C Routine arguments
781     character*(*) fName
782     integer filePrec
783     character*(2) arrType
784     integer nNz, nLocz
785     parameter (nLocz = 1)
786     _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
787     integer irecord
788     integer myThid
789     C Functions
790     integer ILNBLNK
791     integer MDS_RECLEN
792     C Local variables
793     character*(80) dataFName
794 heimbach 1.10 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
795 heimbach 1.2 logical exst
796     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
797     Real*4 r4seg(sNx)
798     Real*8 r8seg(sNx)
799     logical globalFile,fileIsOpen
800     integer length_of_rec
801     character*(max_len_mbuf) msgbuf
802 heimbach 1.9 cph-usesingle(
803     integer ii,jj
804     integer x_size,y_size,iG_IO,jG_IO,npe
805     PARAMETER ( x_size = Nx )
806     PARAMETER ( y_size = Ny )
807     Real*4 xy_buffer_r4(x_size,y_size)
808     Real*8 xy_buffer_r8(x_size,y_size)
809     Real*8 global(Nx,Ny)
810     _RL local(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
811     cph-usesingle)
812    
813 heimbach 1.2 C ------------------------------------------------------------------
814    
815     C Only do I/O if I am the master thread
816     _BEGIN_MASTER( myThid )
817    
818     C Record number must be >= 1
819     if (irecord .LT. 1) then
820     write(msgbuf,'(a,i9.8)')
821     & ' MDSREADFIELD_GL: argument irecord = ',irecord
822     call print_message( msgbuf, standardmessageunit,
823     & SQUEEZE_RIGHT , mythid)
824     write(msgbuf,'(a)')
825     & ' MDSREADFIELD_GL: Invalid value for irecord'
826     call print_error( msgbuf, mythid )
827     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
828     endif
829    
830     C Assume nothing
831     globalFile = .FALSE.
832     fileIsOpen = .FALSE.
833     IL=ILNBLNK( fName )
834    
835     C Assign a free unit number as the I/O channel for this routine
836     call MDSFINDUNIT( dUnit, mythid )
837    
838 heimbach 1.9 if ( useSingleCPUIO ) then
839    
840     C master thread of process 0, only, opens a global file
841     #ifdef ALLOW_USE_MPI
842     IF( mpiMyId .EQ. 0 ) THEN
843     #else
844     IF ( .TRUE. ) THEN
845     #endif /* ALLOW_USE_MPI */
846    
847 heimbach 1.2 C Check first for global file with simple name (ie. fName)
848 heimbach 1.9 dataFName = fName
849     inquire( file=dataFname, exist=exst )
850     if (exst) globalFile = .TRUE.
851 heimbach 1.2
852     C If negative check for global file with MDS name (ie. fName.data)
853 heimbach 1.9 if (.NOT. globalFile) then
854     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
855     inquire( file=dataFname, exist=exst )
856     if (exst) globalFile = .TRUE.
857     endif
858    
859     C If global file is visible to process 0, then open it here.
860     C Otherwise stop program.
861     if ( globalFile) then
862     length_of_rec=MDS_RECLEN( filePrec, x_size*y_size, mythid )
863     open( dUnit, file=dataFName, status='old',
864     & access='direct', recl=length_of_rec )
865     else
866     write(msgbuf,'(2a)') ' MDSREADFIELD: filename: ',dataFName
867     call print_message( msgbuf, standardmessageunit,
868     & SQUEEZE_RIGHT , mythid)
869     call print_error( msgbuf, mythid )
870     write(msgbuf,'(a)')
871     & ' MDSREADFIELD: File does not exist'
872     call print_message( msgbuf, standardmessageunit,
873     & SQUEEZE_RIGHT , mythid)
874     call print_error( msgbuf, mythid )
875     stop 'ABNORMAL END: S/R MDSREADFIELD'
876     endif
877    
878     ENDIF
879    
880     c-- useSingleCpuIO
881     else
882    
883     C Check first for global file with simple name (ie. fName)
884     dataFName = fName
885 heimbach 1.2 inquire( file=dataFname, exist=exst )
886     if (exst) then
887     write(msgbuf,'(a,a)')
888 heimbach 1.9 & ' MDSREADFIELD: opening global file: ',dataFName
889 heimbach 1.2 call print_message( msgbuf, standardmessageunit,
890     & SQUEEZE_RIGHT , mythid)
891     endif
892 heimbach 1.9
893     C If negative check for global file with MDS name (ie. fName.data)
894     if (.NOT. globalFile) then
895     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
896     inquire( file=dataFname, exist=exst )
897     if (exst) then
898     write(msgbuf,'(a,a)')
899     & ' MDSREADFIELD_GL: opening global file: ',dataFName
900     call print_message( msgbuf, standardmessageunit,
901     & SQUEEZE_RIGHT , mythid)
902     globalFile = .TRUE.
903     endif
904     endif
905    
906     c-- useSingleCpuIO
907 heimbach 1.2 endif
908 heimbach 1.7
909 heimbach 1.9 if ( .not. useSingleCpuIO ) then
910     cph if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
911     if ( .not. ( globalFile ) ) then
912 heimbach 1.7
913     C If we are reading from a global file then we open it here
914     if (globalFile) then
915     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
916     open( dUnit, file=dataFName, status='old',
917     & access='direct', recl=length_of_rec )
918     fileIsOpen=.TRUE.
919     endif
920    
921 heimbach 1.2 C Loop over all processors
922     do jp=1,nPy
923     do ip=1,nPx
924     C Loop over all tiles
925     do bj=1,nSy
926     do bi=1,nSx
927     C If we are reading from a tiled MDS file then we open each one here
928     if (.NOT. globalFile) then
929     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
930     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
931     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
932     & fName(1:IL),'.',iG,'.',jG,'.data'
933     inquire( file=dataFname, exist=exst )
934     C Of course, we only open the file if the tile is "active"
935     C (This is a place-holder for the active/passive mechanism
936     if (exst) then
937 heimbach 1.3 if ( debugLevel .GE. debLevA ) then
938     write(msgbuf,'(a,a)')
939 heimbach 1.2 & ' MDSREADFIELD_GL: opening file: ',dataFName
940 heimbach 1.3 call print_message( msgbuf, standardmessageunit,
941 heimbach 1.2 & SQUEEZE_RIGHT , mythid)
942 heimbach 1.3 endif
943 heimbach 1.2 length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
944     open( dUnit, file=dataFName, status='old',
945     & access='direct', recl=length_of_rec )
946     fileIsOpen=.TRUE.
947     else
948     fileIsOpen=.FALSE.
949     write(msgbuf,'(a,a)')
950     & ' MDSREADFIELD_GL: filename: ',dataFName
951     call print_message( msgbuf, standardmessageunit,
952     & SQUEEZE_RIGHT , mythid)
953 heimbach 1.6 call print_error( msgbuf, mythid )
954 heimbach 1.2 write(msgbuf,'(a)')
955     & ' MDSREADFIELD_GL: File does not exist'
956 heimbach 1.6 call print_message( msgbuf, standardmessageunit,
957     & SQUEEZE_RIGHT , mythid)
958 heimbach 1.2 call print_error( msgbuf, mythid )
959     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
960     endif
961     endif
962    
963     if (fileIsOpen) then
964     do k=1,nLocz
965     do j=1,sNy
966 heimbach 1.7 if (globalFile) then
967     iG=bi+(ip-1)*nsx
968     jG=bj+(jp-1)*nsy
969     irec=1 + INT(iG/sNx) + nSx*nPx*(jG+j-1) + nSx*nPx*Ny*(k-1)
970     & + nSx*nPx*Ny*nLocz*(irecord-1)
971     else
972 heimbach 1.2 iG = 0
973     jG = 0
974     irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
975 heimbach 1.7 endif
976 heimbach 1.2 if (filePrec .eq. precFloat32) then
977     read(dUnit,rec=irec) r4seg
978     #ifdef _BYTESWAPIO
979     call MDS_BYTESWAPR4( sNx, r4seg )
980 adcroft 1.1 #endif
981 heimbach 1.2 if (arrType .eq. 'RS') then
982     call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
983     elseif (arrType .eq. 'RL') then
984     call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .TRUE., arr )
985     else
986     write(msgbuf,'(a)')
987     & ' MDSREADFIELD_GL: illegal value for arrType'
988     call print_error( msgbuf, mythid )
989     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
990     endif
991     elseif (filePrec .eq. precFloat64) then
992     read(dUnit,rec=irec) r8seg
993     #ifdef _BYTESWAPIO
994     call MDS_BYTESWAPR8( sNx, r8seg )
995     #endif
996     if (arrType .eq. 'RS') then
997     call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
998     elseif (arrType .eq. 'RL') then
999     call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .TRUE., arr )
1000     else
1001     write(msgbuf,'(a)')
1002     & ' MDSREADFIELD_GL: illegal value for arrType'
1003     call print_error( msgbuf, mythid )
1004     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
1005     endif
1006     else
1007     write(msgbuf,'(a)')
1008     & ' MDSREADFIELD_GL: illegal value for filePrec'
1009     call print_error( msgbuf, mythid )
1010     stop 'ABNORMAL END: S/R MDSREADFIELD_GL'
1011     endif
1012     do ii=1,sNx
1013     arr_gl(ii,bi,ip,j,bj,jp,k)=arr(ii,j,k,bi,bj)
1014     enddo
1015    
1016     C End of j loop
1017     enddo
1018     C End of k loop
1019     enddo
1020     if (.NOT. globalFile) then
1021     close( dUnit )
1022     fileIsOpen = .FALSE.
1023     endif
1024     endif
1025     C End of bi,bj loops
1026     enddo
1027     enddo
1028     C End of ip,jp loops
1029     enddo
1030     enddo
1031    
1032     C If global file was opened then close it
1033     if (fileIsOpen .AND. globalFile) then
1034     close( dUnit )
1035     fileIsOpen = .FALSE.
1036     endif
1037    
1038 heimbach 1.9 c end of if ( .not. ( globalFile ) ) then
1039     endif
1040    
1041     c else of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
1042     else
1043    
1044     DO k=1,nLocz
1045    
1046     #ifdef ALLOW_USE_MPI
1047     IF( mpiMyId .EQ. 0 ) THEN
1048     #else
1049     IF ( .TRUE. ) THEN
1050     #endif /* ALLOW_USE_MPI */
1051     irec = k+nNz*(irecord-1)
1052     if (filePrec .eq. precFloat32) then
1053     read(dUnit,rec=irec) xy_buffer_r4
1054     #ifdef _BYTESWAPIO
1055     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1056     #endif
1057     DO J=1,Ny
1058     DO I=1,Nx
1059     global(I,J) = xy_buffer_r4(I,J)
1060     ENDDO
1061     ENDDO
1062     elseif (filePrec .eq. precFloat64) then
1063     read(dUnit,rec=irec) xy_buffer_r8
1064     #ifdef _BYTESWAPIO
1065     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1066     #endif
1067     DO J=1,Ny
1068     DO I=1,Nx
1069     global(I,J) = xy_buffer_r8(I,J)
1070     ENDDO
1071     ENDDO
1072     else
1073     write(msgbuf,'(a)')
1074     & ' MDSREADFIELD: illegal value for filePrec'
1075     call print_error( msgbuf, mythid )
1076     stop 'ABNORMAL END: S/R MDSREADFIELD'
1077     endif
1078     ENDIF
1079     DO jp=1,nPy
1080     DO ip=1,nPx
1081     DO bj = myByLo(myThid), myByHi(myThid)
1082     DO bi = myBxLo(myThid), myBxHi(myThid)
1083     DO J=1,sNy
1084     JJ=((jp-1)*nSy+(bj-1))*sNy+J
1085     DO I=1,sNx
1086     II=((ip-1)*nSx+(bi-1))*sNx+I
1087     arr_gl(i,bi,ip,j,bj,jp,k) = global(II,JJ)
1088     ENDDO
1089     ENDDO
1090     ENDDO
1091     ENDDO
1092     ENDDO
1093     ENDDO
1094    
1095     ENDDO
1096     c ENDDO k=1,nNz
1097    
1098     close( dUnit )
1099    
1100 heimbach 1.7 endif
1101     c end of if ( .not. ( globalFile .and. useSingleCPUIO ) ) then
1102    
1103 heimbach 1.2 _END_MASTER( myThid )
1104    
1105     C ------------------------------------------------------------------
1106     return
1107     end
1108     C=======================================================================
1109    
1110     C=======================================================================
1111     SUBROUTINE MDSWRITEFIELD_2D_GL(
1112     I fName,
1113     I filePrec,
1114     I arrType,
1115     I nNz,
1116     I arr_gl,
1117     I irecord,
1118     I myIter,
1119     I myThid )
1120     C
1121     C Arguments:
1122     C
1123     C fName string base name for file to written
1124     C filePrec integer number of bits per word in file (32 or 64)
1125     C arrType char(2) declaration of "arr": either "RS" or "RL"
1126     C nNz integer size of third dimension: normally either 1 or Nr
1127     C arr RS/RL array to write, arr(:,:,nNz,:,:)
1128     C irecord integer record number to read
1129     C myIter integer time step number
1130     C myThid integer thread identifier
1131     C
1132     C MDSWRITEFIELD creates either a file of the form "fName.data" and
1133     C "fName.meta" if the logical flag "globalFile" is set true. Otherwise
1134     C it creates MDS tiled files of the form "fName.xxx.yyy.data" and
1135     C "fName.xxx.yyy.meta". A meta-file is always created.
1136     C Currently, the meta-files are not read because it is difficult
1137     C to parse files in fortran. We should read meta information before
1138     C adding records to an existing multi-record file.
1139     C The precision of the file is decsribed by filePrec, set either
1140     C to floatPrec32 or floatPrec64. The precision or declaration of
1141     C the array argument must be consistently described by the char*(2)
1142     C string arrType, either "RS" or "RL". nNz allows for both 2-D and
1143     C 3-D arrays to be handled. nNz=1 implies a 2-D model field and
1144     C nNz=Nr implies a 3-D model field. irecord is the record number
1145     C to be read and must be >= 1. NOTE: It is currently assumed that
1146     C the highest record number in the file was the last record written.
1147     C Nor is there a consistency check between the routine arguments and file.
1148     C ie. if your write record 2 after record 4 the meta information
1149     C will record the number of records to be 2. This, again, is because
1150     C we have read the meta information. To be fixed.
1151     C
1152     C Created: 03/16/99 adcroft@mit.edu
1153     C
1154     C Changed: 05/31/00 heimbach@mit.edu
1155     C open(dUnit, ..., status='old', ... -> status='unknown'
1156    
1157     implicit none
1158     C Global variables / common blocks
1159     #include "SIZE.h"
1160     #include "EEPARAMS.h"
1161 heimbach 1.7 #include "EESUPPORT.h"
1162 heimbach 1.2 #include "PARAMS.h"
1163    
1164     C Routine arguments
1165     character*(*) fName
1166     integer filePrec
1167     character*(2) arrType
1168     integer nNz, nLocz
1169     parameter (nLocz = 1)
1170     cph(
1171     cph Real arr(*)
1172     _RL arr_gl(sNx,nSx,nPx,sNy,nSy,nPy,nLocz)
1173     cph)
1174     integer irecord
1175     integer myIter
1176     integer myThid
1177     C Functions
1178     integer ILNBLNK
1179     integer MDS_RECLEN
1180     C Local variables
1181     character*(80) dataFName,metaFName
1182 heimbach 1.7 integer ip,jp,iG,jG,irec,bi,bj,i,j,k,dUnit,IL
1183 heimbach 1.2 Real*4 r4seg(sNx)
1184     Real*8 r8seg(sNx)
1185     _RL arr(1-oLx:sNx+oLx,1-oLy:sNy+oLy,nLocz,nSx,nSy)
1186     integer dimList(3,3),ndims
1187     integer length_of_rec
1188     logical fileIsOpen
1189     character*(max_len_mbuf) msgbuf
1190 heimbach 1.7 cph-usesingle(
1191     integer ii,jj
1192 heimbach 1.8 integer x_size,y_size,iG_IO,jG_IO,npe
1193 heimbach 1.7 PARAMETER ( x_size = Nx )
1194     PARAMETER ( y_size = Ny )
1195     Real*4 xy_buffer_r4(x_size,y_size)
1196     Real*8 xy_buffer_r8(x_size,y_size)
1197     Real*8 global(Nx,Ny)
1198     cph-usesingle)
1199    
1200 heimbach 1.2 C ------------------------------------------------------------------
1201    
1202     C Only do I/O if I am the master thread
1203     _BEGIN_MASTER( myThid )
1204    
1205     C Record number must be >= 1
1206     if (irecord .LT. 1) then
1207     write(msgbuf,'(a,i9.8)')
1208     & ' MDSWRITEFIELD_GL: argument irecord = ',irecord
1209     call print_message( msgbuf, standardmessageunit,
1210     & SQUEEZE_RIGHT , mythid)
1211     write(msgbuf,'(a)')
1212     & ' MDSWRITEFIELD_GL: invalid value for irecord'
1213     call print_error( msgbuf, mythid )
1214     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1215     endif
1216    
1217     C Assume nothing
1218     fileIsOpen=.FALSE.
1219     IL=ILNBLNK( fName )
1220    
1221     C Assign a free unit number as the I/O channel for this routine
1222     call MDSFINDUNIT( dUnit, mythid )
1223    
1224    
1225 heimbach 1.7 cph-usesingle(
1226     #ifdef ALLOW_USE_MPI
1227     _END_MASTER( myThid )
1228     C If option globalFile is desired but does not work or if
1229     C globalFile is too slow, then try using single-CPU I/O.
1230     if (useSingleCpuIO) then
1231    
1232     C Master thread of process 0, only, opens a global file
1233     _BEGIN_MASTER( myThid )
1234     IF( mpiMyId .EQ. 0 ) THEN
1235     write(dataFname(1:80),'(2a)') fName(1:IL),'.data'
1236     length_of_rec=MDS_RECLEN(filePrec,x_size*y_size,mythid)
1237     if (irecord .EQ. 1) then
1238     open( dUnit, file=dataFName, status=_NEW_STATUS,
1239     & access='direct', recl=length_of_rec )
1240     else
1241     open( dUnit, file=dataFName, status=_OLD_STATUS,
1242     & access='direct', recl=length_of_rec )
1243     endif
1244     ENDIF
1245     _END_MASTER( myThid )
1246    
1247     C Gather array and write it to file, one vertical level at a time
1248     DO k=1,nLocz
1249     C Loop over all processors
1250     do jp=1,nPy
1251     do ip=1,nPx
1252     DO bj = myByLo(myThid), myByHi(myThid)
1253     DO bi = myBxLo(myThid), myBxHi(myThid)
1254     DO J=1,sNy
1255     JJ=((jp-1)*nSy+(bj-1))*sNy+J
1256     DO I=1,sNx
1257     II=((ip-1)*nSx+(bi-1))*sNx+I
1258     global(II,JJ) = arr_gl(i,bi,ip,j,bj,jp,k)
1259     ENDDO
1260     ENDDO
1261     ENDDO
1262     ENDDO
1263     enddo
1264     enddo
1265     _BEGIN_MASTER( myThid )
1266     IF( mpiMyId .EQ. 0 ) THEN
1267     irec=k+nLocz*(irecord-1)
1268     if (filePrec .eq. precFloat32) then
1269     DO J=1,Ny
1270     DO I=1,Nx
1271     xy_buffer_r4(I,J) = global(I,J)
1272     ENDDO
1273     ENDDO
1274     #ifdef _BYTESWAPIO
1275     call MDS_BYTESWAPR4( x_size*y_size, xy_buffer_r4 )
1276     #endif
1277     write(dUnit,rec=irec) xy_buffer_r4
1278     elseif (filePrec .eq. precFloat64) then
1279     DO J=1,Ny
1280     DO I=1,Nx
1281     xy_buffer_r8(I,J) = global(I,J)
1282     ENDDO
1283     ENDDO
1284     #ifdef _BYTESWAPIO
1285     call MDS_BYTESWAPR8( x_size*y_size, xy_buffer_r8 )
1286     #endif
1287     write(dUnit,rec=irec) xy_buffer_r8
1288     else
1289     write(msgbuf,'(a)')
1290     & ' MDSWRITEFIELD: illegal value for filePrec'
1291     call print_error( msgbuf, mythid )
1292     stop 'ABNORMAL END: S/R MDSWRITEFIELD'
1293     endif
1294     ENDIF
1295     _END_MASTER( myThid )
1296     ENDDO
1297    
1298     C Close data-file and create meta-file
1299     _BEGIN_MASTER( myThid )
1300     IF( mpiMyId .EQ. 0 ) THEN
1301     close( dUnit )
1302     write(metaFName(1:80),'(2a)') fName(1:IL),'.meta'
1303     dimList(1,1)=Nx
1304     dimList(2,1)=1
1305     dimList(3,1)=Nx
1306     dimList(1,2)=Ny
1307     dimList(2,2)=1
1308     dimList(3,2)=Ny
1309     dimList(1,3)=nLocz
1310     dimList(2,3)=1
1311     dimList(3,3)=nLocz
1312     ndims=3
1313     if (nLocz .EQ. 1) ndims=2
1314     call MDSWRITEMETA( metaFName, dataFName,
1315     & filePrec, ndims, dimList, irecord, myIter, mythid )
1316     ENDIF
1317     _END_MASTER( myThid )
1318     C To be safe, make other processes wait for I/O completion
1319     _BARRIER
1320    
1321     elseif ( .NOT. useSingleCpuIO ) then
1322     _BEGIN_MASTER( myThid )
1323     #endif /* ALLOW_USE_MPI */
1324     cph-usesingle)
1325    
1326 heimbach 1.2 C Loop over all processors
1327     do jp=1,nPy
1328     do ip=1,nPx
1329     C Loop over all tiles
1330     do bj=1,nSy
1331     do bi=1,nSx
1332     C If we are writing to a tiled MDS file then we open each one here
1333     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1334     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1335     write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')
1336     & fName(1:IL),'.',iG,'.',jG,'.data'
1337     if (irecord .EQ. 1) then
1338     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1339     open( dUnit, file=dataFName, status=_NEW_STATUS,
1340     & access='direct', recl=length_of_rec )
1341     fileIsOpen=.TRUE.
1342     else
1343     length_of_rec=MDS_RECLEN( filePrec, sNx, mythid )
1344     open( dUnit, file=dataFName, status=_OLD_STATUS,
1345     & access='direct', recl=length_of_rec )
1346     fileIsOpen=.TRUE.
1347     endif
1348     if (fileIsOpen) then
1349     do k=1,nLocz
1350     do j=1,sNy
1351     do ii=1,sNx
1352     arr(ii,j,k,bi,bj)=arr_gl(ii,bi,ip,j,bj,jp,k)
1353     enddo
1354     iG = 0
1355     jG = 0
1356     irec=j + sNy*(k-1) + sNy*nLocz*(irecord-1)
1357     if (filePrec .eq. precFloat32) then
1358     if (arrType .eq. 'RS') then
1359     call MDS_SEG4toRS( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1360     elseif (arrType .eq. 'RL') then
1361     call MDS_SEG4toRL( j,bi,bj,k,nLocz, r4seg, .FALSE., arr )
1362     else
1363     write(msgbuf,'(a)')
1364     & ' MDSWRITEFIELD_GL: illegal value for arrType'
1365     call print_error( msgbuf, mythid )
1366     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1367     endif
1368     #ifdef _BYTESWAPIO
1369     call MDS_BYTESWAPR4( sNx, r4seg )
1370     #endif
1371     write(dUnit,rec=irec) r4seg
1372     elseif (filePrec .eq. precFloat64) then
1373     if (arrType .eq. 'RS') then
1374     call MDS_SEG8toRS( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1375     elseif (arrType .eq. 'RL') then
1376     call MDS_SEG8toRL( j,bi,bj,k,nLocz, r8seg, .FALSE., arr )
1377     else
1378     write(msgbuf,'(a)')
1379     & ' MDSWRITEFIELD_GL: illegal value for arrType'
1380     call print_error( msgbuf, mythid )
1381     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1382     endif
1383     #ifdef _BYTESWAPIO
1384     call MDS_BYTESWAPR8( sNx, r8seg )
1385     #endif
1386     write(dUnit,rec=irec) r8seg
1387     else
1388     write(msgbuf,'(a)')
1389     & ' MDSWRITEFIELD_GL: illegal value for filePrec'
1390     call print_error( msgbuf, mythid )
1391     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1392     endif
1393     C End of j loop
1394     enddo
1395     C End of k loop
1396     enddo
1397     else
1398     write(msgbuf,'(a)')
1399     & ' MDSWRITEFIELD_GL: I should never get to this point'
1400     call print_error( msgbuf, mythid )
1401     stop 'ABNORMAL END: S/R MDSWRITEFIELD_GL'
1402     endif
1403     C If we were writing to a tiled MDS file then we close it here
1404     if (fileIsOpen) then
1405     close( dUnit )
1406     fileIsOpen = .FALSE.
1407     endif
1408     C Create meta-file for each tile if we are tiling
1409     iG=bi+(ip-1)*nsx ! Kludge until unstructered tiles
1410     jG=bj+(jp-1)*nsy ! Kludge until unstructered tiles
1411     write(metaFname(1:80),'(2a,i3.3,a,i3.3,a)')
1412     & fName(1:IL),'.',iG,'.',jG,'.meta'
1413     dimList(1,1)=Nx
1414     dimList(2,1)=((ip-1)*nSx+(bi-1))*sNx+1
1415     dimList(3,1)=((ip-1)*nSx+bi)*sNx
1416     dimList(1,2)=Ny
1417     dimList(2,2)=((jp-1)*nSy+(bj-1))*sNy+1
1418     dimList(3,2)=((jp-1)*nSy+bj)*sNy
1419     dimList(1,3)=Nr
1420     dimList(2,3)=1
1421     dimList(3,3)=Nr
1422     ndims=3
1423     if (nLocz .EQ. 1) ndims=2
1424     call MDSWRITEMETA( metaFName, dataFName,
1425     & filePrec, ndims, dimList, irecord, myIter, mythid )
1426     C End of bi,bj loops
1427     enddo
1428     enddo
1429     C End of ip,jp loops
1430     enddo
1431     enddo
1432    
1433 heimbach 1.7 _END_MASTER( myThid )
1434 heimbach 1.2
1435 heimbach 1.7 #ifdef ALLOW_USE_MPI
1436     C endif useSingleCpuIO
1437     endif
1438     #endif /* ALLOW_USE_MPI */
1439 adcroft 1.1
1440     C ------------------------------------------------------------------
1441     return
1442     end
1443     C=======================================================================
  ViewVC Help
Powered by ViewVC 1.1.22