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