/[MITgcm]/MITgcm/pkg/flt/flt_mdsreadvector.F
ViewVC logotype

Diff of /MITgcm/pkg/flt/flt_mdsreadvector.F

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

revision 1.1 by adcroft, Thu Sep 13 17:43:56 2001 UTC revision 1.2 by jmc, Wed Dec 3 01:43:07 2008 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3    
4  #include "FLT_CPPOPTIONS.h"  #include "FLT_OPTIONS.h"
5    
6    
7  #undef  SAFE_IO  #undef  SAFE_IO
# Line 12  C $Name$ Line 12  C $Name$
12  #define _NEW_STATUS 'unknown'  #define _NEW_STATUS 'unknown'
13  #endif  #endif
14    
15        SUBROUTINE MDSREADVECTOR_flt(        SUBROUTINE FLT_MDSREADVECTOR(
16       I   fName,       I   fName,
17       O   globalFile,       O   globalFile,
18       I   filePrec,       I   filePrec,
# Line 45  c Modified: 09/29/00 abiastoch@ucsd.edu Line 45  c Modified: 09/29/00 abiastoch@ucsd.edu
45  c           based on mdsreadvector  c           based on mdsreadvector
46  c           Checks first for local files and then for global  c           Checks first for local files and then for global
47    
48        implicit none        IMPLICIT NONE
49  C Global variables / common blocks  C Global variables / COMMON blocks
50  #include "SIZE.h"  #include "SIZE.h"
51  #include "EEPARAMS.h"  #include "EEPARAMS.h"
52  #include "PARAMS.h"  #include "PARAMS.h"
53    
54  C Routine arguments  C Routine arguments
55        character*(*) fName        CHARACTER*(*) fName
56        integer filePrec        INTEGER filePrec
57        character*(2) arrType        CHARACTER*(2) arrType
58        integer narr        INTEGER narr
59        Real arr(narr)  c     Real arr(narr)
60        integer irecord        _RL arr(narr)
61        integer myThid        INTEGER irecord
62  ce        INTEGER myThid
63        integer bi,bj        INTEGER bi,bj
 ce  
64    
65  C Functions  C Functions
66        integer ILNBLNK        INTEGER  ILNBLNK
67        integer MDS_RECLEN        EXTERNAL ILNBLNK
68          INTEGER  MDS_RECLEN
69          EXTERNAL MDS_RECLEN
70  C Local variables  C Local variables
71        character*(80) dataFName        CHARACTER*(MAX_LEN_FNAM) dataFName
72        integer iG,jG,irec,dUnit,IL        INTEGER i,iG,jG,irec,dUnit,IL,iLfn
73        logical exst        LOGICAL exst
74        logical globalFile,fileIsOpen        LOGICAL globalFile,fileIsOpen
75        integer length_of_rec        INTEGER length_of_rec
76        character*(max_len_mbuf) msgbuf        CHARACTER*(max_len_mbuf) msgbuf
77  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
78    
79  C Only do I/O if I am the master thread  C Only DO I/O IF I am the master thread
80        _BEGIN_MASTER( myThid )        _BEGIN_MASTER( myThid )
81    
82  C Record number must be >= 1  C Record number must be >= 1
83        if (irecord .LT. 1) then        IF (irecord .LT. 1) THEN
84         write(msgbuf,'(a,i9.8)')         WRITE(msgbuf,'(A,I9.8)')
85       &   ' MDSREADVECTOR: argument irecord = ',irecord       &   ' FLT_MDSREADVECTOR: argument irecord = ',irecord
86         call print_message( msgbuf, standardmessageunit,         CALL PRINT_MESSAGE( msgbuf, standardmessageunit,
87       &                     SQUEEZE_RIGHT , mythid)       &                     SQUEEZE_RIGHT , myThid)
88         write(msgbuf,'(a)')         WRITE(msgbuf,'(A)')
89       &   ' MDSREADVECTOR: invalid value for irecord'       &   ' FLT_MDSREADVECTOR: invalid value for irecord'
90         call print_error( msgbuf, mythid )         CALL PRINT_ERROR( msgbuf, myThid )
91         stop 'ABNORMAL END: S/R MDSREADVECTOR'         STOP 'ABNORMAL END: S/R FLT_MDSREADVECTOR'
92        endif        ENDIF
93          IF ( arrType.NE.'RL' ) THEN
94           WRITE(msgbuf,'(3A)')
95         &   ' FLT_MDSREADVECTOR: not yet coded for arrType="',arrType,'"'
96           CALL PRINT_ERROR( msgbuf, myThid )
97           STOP 'ABNORMAL END: S/R FLT_MDSREADVECTOR'
98          ENDIF
99    
100  C Assume nothing  C Assume nothing
101        globalFile = .TRUE.        globalFile = .TRUE.
# Line 96  C Assume nothing Line 103  C Assume nothing
103        IL=ILNBLNK( fName )        IL=ILNBLNK( fName )
104    
105  C Assign a free unit number as the I/O channel for this routine  C Assign a free unit number as the I/O channel for this routine
106        call MDSFINDUNIT( dUnit, mythid )        CALL MDSFINDUNIT( dUnit, myThid )
   
107    
108  C Check first for local file  C Check first for local file
109        iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles        iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
110        jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles        jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
111        write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')        WRITE(dataFname,'(2A,I3.3,A,I3.3,A)')
112       &          fName(1:IL),'.',iG,'.',jG,'.data'       &          fName(1:IL),'.',iG,'.',jG,'.data'
113        inquire( file=dataFname, exist=exst )        INQUIRE( file=dataFname, exist=exst )
114  C Of course, we only open the file if the tile is "active"  C Of course, we only open the file IF the tile is "active"
115  C (This is a place-holder for the active/passive mechanism)  C (This is a place-holder for the active/passive mechanism)
116        if (exst) then        IF (exst) THEN
117         write(msgbuf,'(a,a)')          globalFile = .FALSE.
118       &      ' MDSREADVECTOR: opening file: ',dataFName        ENDIF
           call print_message( msgbuf, standardmessageunit,  
      &                        SQUEEZE_RIGHT , mythid)  
        globalFile = .FALSE.  
       endif  
   
   
119    
120  C If no local file is available check for global files  C If no local file is available check for global files
121        if (globalFile) then        IF (globalFile) THEN
122  C Check first for global file with simple name (ie. fName)  C Check first for global file with simple name (ie. fName)
123        dataFName = fName         WRITE(dataFname,'(2A)') fName(1:IL)
124        inquire( file=dataFname, exist=exst )         iLfn = IL
125        if (exst) then         INQUIRE( file=dataFname, exist=exst )
126         write(msgbuf,'(a,a)')  c      IF (exst) THEN
127       &   ' MDSREADVECTOR: opening global file: ',dataFName  c        write(0,*) 'found file: ',dataFname(1:iLfn)
128         call print_message( msgbuf, standardmessageunit,  c      ENDIF
129       &                     SQUEEZE_RIGHT , mythid)         IF ( .NOT.exst) THEN
130        else          WRITE(dataFname,'(2A)') fName(1:IL),'.data'
131         write(dataFname(1:80),'(2a)') fName(1:IL),'.data'          iLfn = IL+5
132         inquire( file=dataFname, exist=exst )          INQUIRE( file=dataFname, exist=exst )
133         if (exst) then  c       IF (exst) THEN
134           write(msgbuf,'(a,a)')  c        write(0,*) 'found file: ',dataFname(1:iLfn)
135       &     ' MDSREADVECTOR: opening global file: ',dataFName  c       ENDIF
136           call print_message( msgbuf, standardmessageunit,         ENDIF
137       &                       SQUEEZE_RIGHT , mythid)        ENDIF
        endif  
       endif  
        globalFile = .TRUE.  
       endif  
138    
139  C If we are reading from a global file then we open it here  C If we are reading from a global file then we open it here
140        if (globalFile) then        IF (globalFile) THEN
141         length_of_rec=MDS_RECLEN( filePrec, narr, mythid )         IF ( debugLevel.GE.debLevA ) THEN
142         open( dUnit, file=dataFName, status='old',          WRITE(msgbuf,'(A,A)')
143         &   ' FLT_MDSREADVECTOR: opening global file: ',dataFName(1:iLfn)
144            CALL PRINT_MESSAGE( msgbuf, standardmessageunit,
145         &                      SQUEEZE_RIGHT , myThid)
146           ENDIF
147           length_of_rec=MDS_RECLEN( filePrec, narr, myThid )
148           OPEN( dUnit, file=dataFName, status='old',
149       &      access='direct', recl=length_of_rec )       &      access='direct', recl=length_of_rec )
150         fileIsOpen=.TRUE.         fileIsOpen=.TRUE.
151        endif        ENDIF
152    
153  C Loop over all tiles  C Loop over all tiles
154  ce      do bj=1,nSy  ce      DO bj=1,nSy
155  ce       do bi=1,nSx  ce       DO bi=1,nSx
156  C If we are reading from a tiled MDS file then we open each one here  C If we are reading from a tiled MDS file then we open each one here
157          if (.NOT. globalFile) then          IF (.NOT. globalFile) THEN
158           iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles           iG=bi+(myXGlobalLo-1)/sNx ! Kludge until unstructered tiles
159           jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles           jG=bj+(myYGlobalLo-1)/sNy ! Kludge until unstructered tiles
160           write(dataFname(1:80),'(2a,i3.3,a,i3.3,a)')           WRITE(dataFname,'(2A,I3.3,A,I3.3,A)')
161       &              fName(1:IL),'.',iG,'.',jG,'.data'       &              fName(1:IL),'.',iG,'.',jG,'.data'
162           inquire( file=dataFname, exist=exst )           iLfn= IL+8+5
163  C Of course, we only open the file if the tile is "active"           INQUIRE( file=dataFname, exist=exst )
164    C Of course, we only open the file IF the tile is "active"
165  C (This is a place-holder for the active/passive mechanism)  C (This is a place-holder for the active/passive mechanism)
166           if (exst) then           IF (exst) THEN
167            write(msgbuf,'(a,a)')            IF ( debugLevel.GE.debLevA ) THEN
168       &      ' MDSREADVECTOR: opening file: ',dataFName             WRITE(msgbuf,'(A,A)')
169            call print_message( msgbuf, standardmessageunit,       &      ' FLT_MDSREADVECTOR: opening file: ',dataFName(1:iLfn)
170       &                        SQUEEZE_RIGHT , mythid)             CALL PRINT_MESSAGE( msgbuf, standardmessageunit,
171            length_of_rec=MDS_RECLEN( filePrec, narr, mythid )       &                         SQUEEZE_RIGHT , myThid)
172            open( dUnit, file=dataFName, status='old',            ENDIF
173              length_of_rec=MDS_RECLEN( filePrec, narr, myThid )
174              OPEN( dUnit, file=dataFName, status='old',
175       &        access='direct', recl=length_of_rec )       &        access='direct', recl=length_of_rec )
176            fileIsOpen=.TRUE.            fileIsOpen=.TRUE.
177           else           ELSE
178            fileIsOpen=.FALSE.            fileIsOpen=.FALSE.
179            write(msgbuf,'(a)')            WRITE(msgbuf,'(A)')
180       &      ' MDSREADVECTOR: un-active tiles not implemented yet'       &      ' FLT_MDSREADVECTOR: un-active tiles not implemented yet'
181            call print_error( msgbuf, mythid )            CALL PRINT_ERROR( msgbuf, myThid )
182            stop 'ABNORMAL END: S/R MDSREADVECTOR'            STOP 'ABNORMAL END: S/R FLT_MDSREADVECTOR'
183           endif           ENDIF
184          endif          ENDIF
185          if (fileIsOpen) then  
186            IF (fileIsOpen) THEN
187            irec = irecord            irec = irecord
188            if (filePrec .eq. precFloat32) then            IF (filePrec .EQ. precFloat32) THEN
189             call MDS_READ_RS_VEC( dUnit, irec, narr, arr, myThid )  C-    wrong S/R call: should be MDS_READ_R4_VEC_RL (if arrType=RL)
190            elseif (filePrec .eq. precFloat64) then  C-                           or MDS_READ_R4_VEC_RS (if arrType=RS)
191             call MDS_READ_RL_VEC( dUnit, irec, narr, arr, myThid )  c          CALL MDS_READ_RS_VEC( dUnit, irec, narr, arr, myThid )
192            else             WRITE(msgbuf,'(A,I8)')
193              write(msgbuf,'(a)')       &     ' FLT_MDSREADVECTOR: not yet coded for filePrec=',filePrec
194       &        ' MDSREADVECTOR: illegal value for filePrec'             CALL PRINT_ERROR( msgbuf, myThid )
195              call print_error( msgbuf, mythid )             STOP 'ABNORMAL END: S/R FLT_MDSREADVECTOR'
196              stop 'ABNORMAL END: S/R MDSREADVECTOR'            ELSEIF (filePrec .EQ. precFloat64) THEN
197            endif  C-    wrong S/R call: should be MDS_READ_R8_VEC_RL (if arrType=RL)
198            if (.NOT. globalFile) then  C-                           or MDS_READ_R8_VEC_RS (if arrType=RS)
199              close( dUnit )  C-    + byte-swapp should be inside MDS_READ_RL_VEC
200    c          CALL MDS_READ_RL_VEC( dUnit, irec, narr, arr, myThid )
201               READ( dUnit, rec=irec ) ( arr(i),i=1,narr )
202    #ifdef _BYTESWAPIO
203               CALL MDS_BYTESWAPR8( narr, arr )
204    #endif
205              ELSE
206                WRITE(msgbuf,'(A)')
207         &        ' FLT_MDSREADVECTOR: illegal value for filePrec'
208                CALL PRINT_ERROR( msgbuf, myThid )
209                STOP 'ABNORMAL END: S/R FLT_MDSREADVECTOR'
210              ENDIF
211              IF (.NOT. globalFile) THEN
212                CLOSE( dUnit )
213              fileIsOpen = .FALSE.              fileIsOpen = .FALSE.
214            endif            ENDIF
215          endif          ENDIF
216  C End of bi,bj loops  C End of bi,bj loops
217  ce       enddo  ce       ENDDO
218  ce      enddo  ce      ENDDO
219    
220  C If global file was opened then close it  C If global file was opened then close it
221        if (fileIsOpen .AND. globalFile) then        IF (fileIsOpen .AND. globalFile) THEN
222          close( dUnit )          CLOSE( dUnit )
223          fileIsOpen = .FALSE.          fileIsOpen = .FALSE.
224        endif        ENDIF
225    
226        _END_MASTER( myThid )        _END_MASTER( myThid )
227    
228  C     ------------------------------------------------------------------  C     ------------------------------------------------------------------
229        return        RETURN
230        end        END
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.2
  ViewVC Help
Powered by ViewVC 1.1.22