/[MITgcm]/MITgcm/model/src/ini_curvilinear_grid.F
ViewVC logotype

Diff of /MITgcm/model/src/ini_curvilinear_grid.F

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

revision 1.2 by adcroft, Tue May 29 14:01:37 2001 UTC revision 1.26 by jmc, Fri Jun 9 16:56:05 2006 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3    
4    #include "PACKAGES_CONFIG.h"
5  #include "CPP_OPTIONS.h"  #include "CPP_OPTIONS.h"
6    
7    CBOP
8    C     !ROUTINE: INI_CURVILINEAR_GRID
9    C     !INTERFACE:
10        SUBROUTINE INI_CURVILINEAR_GRID( myThid )        SUBROUTINE INI_CURVILINEAR_GRID( myThid )
11  C     /==========================================================\  C     !DESCRIPTION: \bv
12  C     | SUBROUTINE INI_CURVILINEAR_GRID                          |  C     *==========================================================*
13  C     | o Initialise curvilinear coordinate system               |  C     | SUBROUTINE INI_CURVILINEAR_GRID                          
14  C     |==========================================================|  C     | o Initialise curvilinear coordinate system                
15  C     \==========================================================/  C     *==========================================================*
16        IMPLICIT NONE  C     | Curvilinear grid settings are read from a file rather
17    C     | than coded in-line as for cartesian and spherical polar.
18    C     | This is more general but you have to create the grid
19    C     | yourself.
20    C     *==========================================================*
21    C     \ev
22    
23    C     !USES:
24          IMPLICIT NONE
25  C     === Global variables ===  C     === Global variables ===
26  #include "SIZE.h"  #include "SIZE.h"
27  #include "EEPARAMS.h"  #include "EEPARAMS.h"
28  #include "PARAMS.h"  #include "PARAMS.h"
29  #include "GRID.h"  #include "GRID.h"
30    #ifdef ALLOW_EXCH2
31    #include "W2_EXCH2_TOPOLOGY.h"
32    #include "W2_EXCH2_PARAMS.h"
33    #endif
34    #ifdef ALLOW_MNC
35    #include "MNC_PARAMS.h"
36    #endif
37    
38    #ifndef ALLOW_EXCH2
39    C- note: default is to use "new" grid files (OLD_GRID_IO undef) with EXCH2
40    C    but can still use (on 1 cpu) OLD_GRID_IO and EXCH2 independently
41    #ifdef ALLOW_MDSIO
42    #define OLD_GRID_IO
43    #endif
44    #endif /* ALLOW_EXCH2 */
45    
46    C     !INPUT/OUTPUT PARAMETERS:
47  C     == Routine arguments ==  C     == Routine arguments ==
48  C     myThid -  Number of this instance of INI_CARTESIAN_GRID  C     myThid -  Number of this instance of INI_CURVILINEAR_GRID
49        INTEGER myThid        INTEGER myThid
50    
51    C     !LOCAL VARIABLES:
52  C     == Local variables ==  C     == Local variables ==
53        INTEGER bi,bj        INTEGER bi,bj, myIter
54        INTEGER I,J        INTEGER I,J
55          CHARACTER*(MAX_LEN_MBUF) msgBuf
56    #ifdef ALLOW_MNC
57          CHARACTER*(80) mncFn
58    #endif
59    #ifndef OLD_GRID_IO
60    # ifdef ALLOW_EXCH2
61          _RL buf(sNx*nSx*nPx+1)
62          INTEGER myTile
63    # else
64          _RL buf(sNx+1,sNy+1)
65    # endif
66          INTEGER iG, iL, iLen
67          CHARACTER*(MAX_LEN_FNAM) fName
68          CHARACTER*(MAX_LEN_MBUF) tmpBuf
69          INTEGER  ILNBLNK
70          EXTERNAL ILNBLNK
71    #endif
72    CEOP
73    
74  C--   Set everything to zero everywhere  C--   Set everything to zero everywhere
75        DO bj = myByLo(myThid), myByHi(myThid)        DO bj = myByLo(myThid), myByHi(myThid)
# Line 49  C--   Set everything to zero everywhere Line 95  C--   Set everything to zero everywhere
95            RAS(i,j,bi,bj)=0.            RAS(i,j,bi,bj)=0.
96            tanPhiAtU(i,j,bi,bj)=0.            tanPhiAtU(i,j,bi,bj)=0.
97            tanPhiAtV(i,j,bi,bj)=0.            tanPhiAtV(i,j,bi,bj)=0.
98              angleCosC(i,j,bi,bj)=1.
99              angleSinC(i,j,bi,bj)=0.
100            cosFacU(J,bi,bj)=1.            cosFacU(J,bi,bj)=1.
101            cosFacV(J,bi,bj)=1.            cosFacV(J,bi,bj)=1.
102            sqcosFacU(J,bi,bj)=1.            sqcosFacU(J,bi,bj)=1.
# Line 56  C--   Set everything to zero everywhere Line 104  C--   Set everything to zero everywhere
104           ENDDO           ENDDO
105          ENDDO          ENDDO
106    
107         ENDDO ! bi         ENDDO
108        ENDDO ! bj        ENDDO
109    
110    
111    #ifdef ALLOW_MNC
112          IF (useMNC .AND. readgrid_mnc) THEN
113    
114            _BEGIN_MASTER(myThid)
115            DO i = 1,80
116              mncFn(i:i) = ' '
117            ENDDO
118            write(mncFn,'(a)') 'mitgrid'
119            DO i = 1,MAX_LEN_MBUF
120              msgBuf(i:i) = ' '
121            ENDDO
122            WRITE(msgBuf,'(2A)') msgBuf,' ; Reading grid info using MNC'
123            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
124         &       SQUEEZE_RIGHT , myThid)
125            CALL MNC_FILE_CLOSE_ALL_MATCHING(mncFn, myThid)
126            CALL MNC_CW_SET_UDIM(mncFn, 1, myThid)
127            CALL MNC_CW_SET_CITER(mncFn, 2, -1, -1, -1, myThid)
128            CALL MNC_CW_SET_UDIM(mncFn, 1, myThid)
129            CALL MNC_CW_RS_R('D',mncFn,0,0,'XC', XC,  myThid)
130            CALL MNC_CW_RS_R('D',mncFn,0,0,'XG', XG,  myThid)
131            CALL MNC_CW_RS_R('D',mncFn,0,0,'YC', YC,  myThid)
132            CALL MNC_CW_RS_R('D',mncFn,0,0,'YG', YG,  myThid)
133            CALL MNC_CW_RS_R('D',mncFn,0,0,'dxC',DXC, myThid)
134            CALL MNC_CW_RS_R('D',mncFn,0,0,'dyC',DYC, myThid)
135            CALL MNC_CW_RS_R('D',mncFn,0,0,'dxF',DXF, myThid)
136            CALL MNC_CW_RS_R('D',mncFn,0,0,'dyF',DYF, myThid)
137            CALL MNC_CW_RS_R('D',mncFn,0,0,'dxG',DXG, myThid)
138            CALL MNC_CW_RS_R('D',mncFn,0,0,'dyG',DYG, myThid)
139            CALL MNC_CW_RS_R('D',mncFn,0,0,'dxV',DXV, myThid)
140            CALL MNC_CW_RS_R('D',mncFn,0,0,'dyU',DYU, myThid)
141            CALL MNC_CW_RS_R('D',mncFn,0,0,'rA', RA,  myThid)
142            CALL MNC_CW_RS_R('D',mncFn,0,0,'rAz',RAZ, myThid)
143            CALL MNC_CW_RS_R('D',mncFn,0,0,'rAw',RAW, myThid)
144            CALL MNC_CW_RS_R('D',mncFn,0,0,'rAs',RAS, myThid)
145            CALL MNC_CW_RS_R('D',mncFn,0,0,'AngleCS',angleCosC,myThid)
146            CALL MNC_CW_RS_R('D',mncFn,0,0,'AngleSN',angleSinC,myThid)
147    
148            _END_MASTER(myThid)
149    
150            CALL EXCH_XY_RS(XC,myThid)
151            CALL EXCH_XY_RS(YC,myThid)
152    #ifdef HRCUBE
153            CALL EXCH_XY_RS(DXF,myThid)
154            CALL EXCH_XY_RS(DYF,myThid)
155    #endif
156            CALL EXCH_XY_RS(RA,myThid )
157            CALL EXCH_Z_XY_RS(XG,myThid)
158            CALL EXCH_Z_XY_RS(YG,myThid)
159            CALL EXCH_Z_XY_RS(RAZ,myThid)
160            CALL EXCH_UV_XY_RS(DXC,DYC,.FALSE.,myThid)
161            CALL EXCH_UV_XY_RS(RAW,RAS,.FALSE.,myThid)
162            CALL EXCH_UV_XY_RS(DYG,DXG,.FALSE.,myThid)
163            CALL EXCH_UV_AGRID_XY_RS(angleSinC,angleCosC,.TRUE.,myThid)
164    
165          ELSE
166    #endif
167    
168  C     Here we make no assumptions about grid symmetry and simply  C     Here we make no assumptions about grid symmetry and simply
169  C     read the raw grid data from files  C     read the raw grid data from files
170    
171    #ifdef OLD_GRID_IO
172    
173  C-    Cell centered quantities  C-    Cell centered quantities
174        CALL MDSREADFIELD('LONC.bin',readBinaryPrec,'RL',1,XC,  1,myThid)        CALL MDSREADFIELD('LONC.bin',readBinaryPrec,'RS',1,XC,  1,myThid)
175        CALL MDSREADFIELD('LATC.bin',readBinaryPrec,'RL',1,YC,  1,myThid)        CALL MDSREADFIELD('LATC.bin',readBinaryPrec,'RS',1,YC,  1,myThid)
176        _EXCH_XY_R4(XC,myThid)        _EXCH_XY_R4(XC,myThid)
177        _EXCH_XY_R4(YC,myThid)        _EXCH_XY_R4(YC,myThid)
178    
179        CALL MDSREADFIELD('DXF.bin',readBinaryPrec,'RL',1,DXF,  1,myThid)        CALL MDSREADFIELD('DXF.bin',readBinaryPrec,'RS',1,DXF,  1,myThid)
180        CALL MDSREADFIELD('DYF.bin',readBinaryPrec,'RL',1,DYF,  1,myThid)        CALL MDSREADFIELD('DYF.bin',readBinaryPrec,'RS',1,DYF,  1,myThid)
181  C !!! _EXCH_OUV_XY_R4(DXF, DYF, unSigned, myThid )  C !!! _EXCH_OUV_XY_R4(DXF, DYF, unSigned, myThid )
182  cs!   this is not correct! <= need paired exchange for DXF,DYF  cs!   this is not correct! <= need paired exchange for DXF,DYF
183        _EXCH_XY_R4(DXF,myThid)        _EXCH_XY_R4(DXF,myThid)
184        _EXCH_XY_R4(DYF,myThid)        _EXCH_XY_R4(DYF,myThid)
185          IF (useCubedSphereExchange) THEN
186    cs! fix overlaps:
187          DO bj = myByLo(myThid), myByHi(myThid)
188           DO bi = myBxLo(myThid), myBxHi(myThid)
189            DO j=1,sNy
190             DO i=1,Olx
191              DXF(1-i,j,bi,bj)=DXF(i,j,bi,bj)
192              DXF(sNx+i,j,bi,bj)=DXF(sNx+1-i,j,bi,bj)
193              DYF(1-i,j,bi,bj)=DYF(i,j,bi,bj)
194              DYF(sNx+i,j,bi,bj)=DYF(sNx+1-i,j,bi,bj)
195             ENDDO
196            ENDDO
197            DO j=1,Oly
198             DO i=1,sNx
199              DXF(i,1-j,bi,bj)=DXF(i,j,bi,bj)
200              DXF(i,sNy+j,bi,bj)=DXF(i,sNy+1-j,bi,bj)
201              DYF(i,1-j,bi,bj)=DYF(i,j,bi,bj)
202              DYF(i,sNy+j,bi,bj)=DYF(i,sNy+1-j,bi,bj)
203             ENDDO
204            ENDDO
205           ENDDO
206          ENDDO
207          ENDIF
208    cs
209    
210        CALL MDSREADFIELD('RA.bin',readBinaryPrec,'RL',1,RA,  1,myThid)        CALL MDSREADFIELD('RA.bin',readBinaryPrec,'RS',1,RA,  1,myThid)
211        _EXCH_XY_R4(RA,myThid )        _EXCH_XY_R4(RA,myThid )
212    
213  C-    Corner quantities  C-    Corner quantities
214  C       *********** this are not degbugged ************  C       *********** this are not degbugged ************
215        CALL MDSREADFIELD('LONG.bin',readBinaryPrec,'RL',1,XG,  1,myThid)        CALL MDSREADFIELD('LONG.bin',readBinaryPrec,'RS',1,XG,  1,myThid)
216        CALL MDSREADFIELD('LATG.bin',readBinaryPrec,'RL',1,YG,  1,myThid)        CALL MDSREADFIELD('LATG.bin',readBinaryPrec,'RS',1,YG,  1,myThid)
217          IF (useCubedSphereExchange) THEN
218  cs-   this block needed by cubed sphere until we write more useful I/O routines  cs-   this block needed by cubed sphere until we write more useful I/O routines
219        bi=3        bi=3
220        bj=1        bj=1
# Line 98  cs-   this block needed by cubed sphere Line 231  cs-   this block needed by cubed sphere
231        bj=bj+2        bj=bj+2
232        YG(sNx+1,1,bj,1)=YG(1,1,bi,1)        YG(sNx+1,1,bj,1)=YG(1,1,bi,1)
233  cs-   end block  cs-   end block
234          ENDIF
235        CALL EXCH_Z_XY_RS(XG,myThid)        CALL EXCH_Z_XY_RS(XG,myThid)
236        CALL EXCH_Z_XY_RS(YG,myThid)        CALL EXCH_Z_XY_RS(YG,myThid)
237    
238        CALL MDSREADFIELD('DXV.bin',readBinaryPrec,'RL',1,DXV,  1,myThid)        CALL MDSREADFIELD('DXV.bin',readBinaryPrec,'RS',1,DXV,  1,myThid)
239        CALL MDSREADFIELD('DYU.bin',readBinaryPrec,'RL',1,DYU,  1,myThid)        CALL MDSREADFIELD('DYU.bin',readBinaryPrec,'RS',1,DYU,  1,myThid)
240  cs-   this block needed by cubed sphere until we write more useful I/O routines  cs-   this block needed by cubed sphere until we write more useful I/O routines
241  C !!! _EXCH_ZUV_XY_R4(DXV, DYU, unSigned, myThid)  C !!! _EXCH_ZUV_XY_R4(DXV, DYU, unSigned, myThid)
242  cs!   this is not correct <= need paired exchange for dxv,dyu  cs!   this is not correct <= need paired exchange for dxv,dyu
243          IF (.NOT.useCubedSphereExchange) THEN
244        CALL EXCH_Z_XY_RS(DXV,myThid)        CALL EXCH_Z_XY_RS(DXV,myThid)
245        CALL EXCH_Z_XY_RS(DYU,myThid)        CALL EXCH_Z_XY_RS(DYU,myThid)
246          ELSE
247        DO bj = myByLo(myThid), myByHi(myThid)        DO bj = myByLo(myThid), myByHi(myThid)
248         DO bi = myBxLo(myThid), myBxHi(myThid)         DO bi = myBxLo(myThid), myBxHi(myThid)
249          DXV(sNx+1,1,bi,bj)=DXV(1,1,bi,bj)  cs! fix overlaps:
250          DXV(1,sNy+1,bi,bj)=DXV(1,1,bi,bj)          DO j=1,sNy
251          DYU(sNx+1,1,bi,bj)=DYU(1,1,bi,bj)           DO i=1,Olx
252          DYU(1,sNy+1,bi,bj)=DYU(1,1,bi,bj)            DXV(1-i,j,bi,bj)=DXV(1+i,j,bi,bj)
253              DXV(sNx+i,j,bi,bj)=DXV(i,j,bi,bj)
254              DYU(1-i,j,bi,bj)=DYU(1+i,j,bi,bj)
255              DYU(sNx+i,j,bi,bj)=DYU(i,j,bi,bj)
256             ENDDO
257            ENDDO
258            DO j=1,Oly
259             DO i=1-Olx,sNx+Olx
260              DXV(i,1-j,bi,bj)=DXV(i,1+j,bi,bj)
261              DXV(i,sNy+j,bi,bj)=DXV(i,j,bi,bj)
262              DYU(i,1-j,bi,bj)=DYU(i,1+j,bi,bj)
263              DYU(i,sNy+j,bi,bj)=DYU(i,j,bi,bj)
264             ENDDO
265            ENDDO
266         ENDDO         ENDDO
267        ENDDO        ENDDO
268  cs-   end block  cs-   end block
269  C !!! _EXCH_ZUV_XY_R4(DXV, DYU, unSigned, myThid)        ENDIF
 cs!   this is not correct <= need paired exchange for dxv,dyu  
       CALL EXCH_Z_XY_RS(DXV,myThid)  
       CALL EXCH_Z_XY_RS(DYU,myThid)  
270    
271        CALL MDSREADFIELD('RAZ.bin',readBinaryPrec,'RL',1,RAZ,  1,myThid)        CALL MDSREADFIELD('RAZ.bin',readBinaryPrec,'RS',1,RAZ,  1,myThid)
272          IF (useCubedSphereExchange) THEN
273  cs-   this block needed by cubed sphere until we write more useful I/O routines  cs-   this block needed by cubed sphere until we write more useful I/O routines
274        CALL EXCH_Z_XY_RS(RAZ , myThid )        CALL EXCH_Z_XY_RS(RAZ , myThid )
275        DO bj = myByLo(myThid), myByHi(myThid)        DO bj = myByLo(myThid), myByHi(myThid)
# Line 132  cs-   this block needed by cubed sphere Line 279  cs-   this block needed by cubed sphere
279         ENDDO         ENDDO
280        ENDDO        ENDDO
281  cs-   end block  cs-   end block
282          ENDIF
283        CALL EXCH_Z_XY_RS(RAZ,myThid)        CALL EXCH_Z_XY_RS(RAZ,myThid)
284    
285  C-    Staggered (u,v pairs) quantities  C-    Staggered (u,v pairs) quantities
286        CALL MDSREADFIELD('DXC.bin',readBinaryPrec,'RL',1,DXC,  1,myThid)        CALL MDSREADFIELD('DXC.bin',readBinaryPrec,'RS',1,DXC,  1,myThid)
287        CALL MDSREADFIELD('DYC.bin',readBinaryPrec,'RL',1,DYC,  1,myThid)        CALL MDSREADFIELD('DYC.bin',readBinaryPrec,'RS',1,DYC,  1,myThid)
288        CALL EXCH_UV_XY_RS(DXC,DYC,.FALSE.,myThid)        CALL EXCH_UV_XY_RS(DXC,DYC,.FALSE.,myThid)
289    
290        CALL MDSREADFIELD('RAW.bin',readBinaryPrec,'RL',1,RAW,  1,myThid)        CALL MDSREADFIELD('RAW.bin',readBinaryPrec,'RS',1,RAW,  1,myThid)
291        CALL MDSREADFIELD('RAS.bin',readBinaryPrec,'RL',1,RAS,  1,myThid)        CALL MDSREADFIELD('RAS.bin',readBinaryPrec,'RS',1,RAS,  1,myThid)
292          IF (useCubedSphereExchange) THEN
293  cs-   this block needed by cubed sphere until we write more useful I/O routines  cs-   this block needed by cubed sphere until we write more useful I/O routines
294        DO bj = myByLo(myThid), myByHi(myThid)        DO bj = myByLo(myThid), myByHi(myThid)
295         DO bi = myBxLo(myThid), myBxHi(myThid)         DO bi = myBxLo(myThid), myBxHi(myThid)
# Line 151  c        RAS(J,sNy+1,bi,bj)=RAS(J,1,bi,b Line 300  c        RAS(J,sNy+1,bi,bj)=RAS(J,1,bi,b
300         ENDDO         ENDDO
301        ENDDO        ENDDO
302  cs-   end block  cs-   end block
303          ENDIF
304        CALL EXCH_UV_XY_RS(RAW,RAS,.FALSE.,myThid)        CALL EXCH_UV_XY_RS(RAW,RAS,.FALSE.,myThid)
305    
306        CALL MDSREADFIELD('DXG.bin',readBinaryPrec,'RL',1,DXG,  1,myThid)        CALL MDSREADFIELD('DXG.bin',readBinaryPrec,'RS',1,DXG,  1,myThid)
307        CALL MDSREADFIELD('DYG.bin',readBinaryPrec,'RL',1,DYG,  1,myThid)        CALL MDSREADFIELD('DYG.bin',readBinaryPrec,'RS',1,DYG,  1,myThid)
308          IF (useCubedSphereExchange) THEN
309  cs-   this block needed by cubed sphere until we write more useful I/O routines  cs-   this block needed by cubed sphere until we write more useful I/O routines
310        DO bj = myByLo(myThid), myByHi(myThid)        DO bj = myByLo(myThid), myByHi(myThid)
311         DO bi = myBxLo(myThid), myBxHi(myThid)         DO bi = myBxLo(myThid), myBxHi(myThid)
# Line 165  c        DXG(J,sNy+1,bi,bj)=DXG(J,1,bi,b Line 316  c        DXG(J,sNy+1,bi,bj)=DXG(J,1,bi,b
316         ENDDO         ENDDO
317        ENDDO        ENDDO
318  cs-   end block  cs-   end block
319          ENDIF
320        CALL EXCH_UV_XY_RS(DYG,DXG,.FALSE.,myThid)        CALL EXCH_UV_XY_RS(DYG,DXG,.FALSE.,myThid)
321          CALL EXCH_UV_AGRID_XY_RS(angleSinC,angleCosC,.TRUE.,myThid)
322    
323  c     write(10) XC  c     write(10) XC
324  c     write(10) YC  c     write(10) YC
# Line 184  c     write(10) RAS Line 337  c     write(10) RAS
337  c     write(10) DXG  c     write(10) DXG
338  c     write(10) DYG  c     write(10) DYG
339    
340    #else /* ifndef OLD_GRID_IO */
341    
342    C--   Only do I/O if I am the master thread
343          _BEGIN_MASTER(myThid)
344    
345          DO bj = 1,nSy
346           DO bi = 1,nSx
347            iG=bi+(myXGlobalLo-1)/sNx
348            WRITE(tmpBuf,'(A,I4)') 'tile:',iG
349    #ifdef ALLOW_EXCH2
350            myTile = W2_myTileList(bi)
351            WRITE(tmpBuf,'(A,I4)') 'tile:',myTile
352            iG = exch2_myface(myTile)
353    #endif
354            iLen = ILNBLNK(horizGridFile)
355            IF ( iLen .EQ. 0 ) THEN
356              WRITE(fName,'("tile",I3.3,".mitgrid")') iG
357            ELSE
358              WRITE(fName,'(2A,I3.3,A)') horizGridFile(1:iLen),
359         &                              '.face',iG,'.bin'
360            ENDIF
361            iLen = ILNBLNK(fName)
362            iL = ILNBLNK(tmpBuf)
363            WRITE(msgBuf,'(3A)') tmpBuf(1:iL),
364         &                   ' ; Read from file ',fName(1:iLen)
365            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
366         &                      SQUEEZE_RIGHT , myThid)
367            WRITE(msgBuf,'(A)') '  =>'
368    
369            CALL READSYMTILE_RS(fName,1,XC,bi,bj,buf,myThid)
370            iL = ILNBLNK(msgBuf)
371            WRITE(tmpBuf,'(A,1X,A)') msgBuf(1:iL),'XC'
372            CALL READSYMTILE_RS(fName,2,YC,bi,bj,buf,myThid)
373            iL = ILNBLNK(tmpBuf)
374            WRITE(msgBuf,'(A,1X,A)') tmpBuf(1:iL),'YC'
375            CALL READSYMTILE_RS(fName,3,DXF,bi,bj,buf,myThid)
376            iL = ILNBLNK(msgBuf)
377            WRITE(tmpBuf,'(A,1X,A)') msgBuf(1:iL),'DXF'
378            CALL READSYMTILE_RS(fName,4,DYF,bi,bj,buf,myThid)
379            iL = ILNBLNK(tmpBuf)
380            WRITE(msgBuf,'(A,1X,A)') tmpBuf(1:iL),'DYF'
381            CALL READSYMTILE_RS(fName,5,RA,bi,bj,buf,myThid)
382            iL = ILNBLNK(msgBuf)
383            WRITE(tmpBuf,'(A,1X,A)') msgBuf(1:iL),'RA'
384            CALL READSYMTILE_RS(fName,6,XG,bi,bj,buf,myThid)
385            iL = ILNBLNK(tmpBuf)
386            WRITE(msgBuf,'(A,1X,A)') tmpBuf(1:iL),'XG'
387            CALL READSYMTILE_RS(fName,7,YG,bi,bj,buf,myThid)
388            iL = ILNBLNK(msgBuf)
389            WRITE(tmpBuf,'(A,1X,A)') msgBuf(1:iL),'YG'
390            CALL READSYMTILE_RS(fName,8,DXV,bi,bj,buf,myThid)
391            iL = ILNBLNK(tmpBuf)
392            WRITE(msgBuf,'(A,1X,A)') tmpBuf(1:iL),'DXV'
393            CALL READSYMTILE_RS(fName,9,DYU,bi,bj,buf,myThid)
394            iL = ILNBLNK(msgBuf)
395            WRITE(tmpBuf,'(A,1X,A)') msgBuf(1:iL),'DYU'
396            CALL READSYMTILE_RS(fName,10,RAZ,bi,bj,buf,myThid)
397            iL = ILNBLNK(tmpBuf)
398            WRITE(msgBuf,'(A,1X,A)') tmpBuf(1:iL),'RAZ'
399            CALL READSYMTILE_RS(fName,11,DXC,bi,bj,buf,myThid)
400            iL = ILNBLNK(msgBuf)
401            WRITE(tmpBuf,'(A,1X,A)') msgBuf(1:iL),'DXC'
402            CALL READSYMTILE_RS(fName,12,DYC,bi,bj,buf,myThid)
403            iL = ILNBLNK(tmpBuf)
404            WRITE(msgBuf,'(A,1X,A)') tmpBuf(1:iL),'DYC'
405            CALL READSYMTILE_RS(fName,13,RAW,bi,bj,buf,myThid)
406            iL = ILNBLNK(msgBuf)
407            WRITE(tmpBuf,'(A,1X,A)') msgBuf(1:iL),'RAW'
408            CALL READSYMTILE_RS(fName,14,RAS,bi,bj,buf,myThid)
409            iL = ILNBLNK(tmpBuf)
410            WRITE(msgBuf,'(A,1X,A)') tmpBuf(1:iL),'RAS'
411            CALL READSYMTILE_RS(fName,15,DXG,bi,bj,buf,myThid)
412            iL = ILNBLNK(msgBuf)
413            WRITE(tmpBuf,'(A,1X,A)') msgBuf(1:iL),'DXG'
414            CALL READSYMTILE_RS(fName,16,DYG,bi,bj,buf,myThid)
415            iL = ILNBLNK(tmpBuf)
416            WRITE(msgBuf,'(A,1X,A)') tmpBuf(1:iL),'DYG'
417    
418            iLen = ILNBLNK(horizGridFile)
419            IF ( iLen.GT.0 ) THEN
420             CALL READSYMTILE_RS(fName,17,angleCosC,bi,bj,buf,myThid)
421             iL = ILNBLNK(msgBuf)
422             WRITE(tmpBuf,'(A,1X,A)') msgBuf(1:iL),'AngleCS'
423             CALL READSYMTILE_RS(fName,18,angleSinC,bi,bj,buf,myThid)
424             iL = ILNBLNK(tmpBuf)
425             WRITE(msgBuf,'(A,1X,A)') tmpBuf(1:iL),'AngleSN'
426            ENDIF
427    
428            CALL PRINT_MESSAGE( msgBuf, standardMessageUnit,
429         &                      SQUEEZE_RIGHT , myThid)
430    
431           ENDDO
432          ENDDO
433    
434          _END_MASTER(myThid)
435    
436          CALL EXCH_XY_RS(XC,myThid)
437          CALL EXCH_XY_RS(YC,myThid)
438    C !!! _EXCH_OUV_XY_R4(DXF, DYF, unSigned, myThid )
439    #ifdef HRCUBE
440          CALL EXCH_XY_RS(DXF,myThid)
441          CALL EXCH_XY_RS(DYF,myThid)
442    #endif
443          CALL EXCH_XY_RS(RA,myThid )
444          CALL EXCH_Z_XY_RS(XG,myThid)
445          CALL EXCH_Z_XY_RS(YG,myThid)
446    C !!! _EXCH_ZUV_XY_R4(DXV, DYU, unSigned, myThid)
447    c     CALL EXCH_Z_XY_RS(DXV,myThid)
448    c     CALL EXCH_Z_XY_RS(DYU,myThid)
449          CALL EXCH_Z_XY_RS(RAZ,myThid)
450          CALL EXCH_UV_XY_RS(DXC,DYC,.FALSE.,myThid)
451          CALL EXCH_UV_XY_RS(RAW,RAS,.FALSE.,myThid)
452          CALL EXCH_UV_XY_RS(DYG,DXG,.FALSE.,myThid)
453          CALL EXCH_UV_AGRID_XY_RS(angleSinC,angleCosC,.TRUE.,myThid)
454    
455    #endif /* OLD_GRID_IO */
456    
457    #ifdef ALLOW_MNC
458          ENDIF
459    #endif /* ALLOW_MNC */
460    
461    c     CALL WRITE_FULLARRAY_RL('DXV',DXV,1,0,0,0,myThid)
462    c     CALL WRITE_FULLARRAY_RL('DYU',DYU,1,0,0,0,myThid)
463    c     CALL WRITE_FULLARRAY_RL('RAZ',RAZ,1,0,0,0,myThid)
464    c     CALL WRITE_FULLARRAY_RL('XG',XG,1,0,0,0,myThid)
465    c     CALL WRITE_FULLARRAY_RL('YG',YG,1,0,0,0,myThid)
466    
467    C--   Now let's look at all these beasts
468          IF ( debugLevel .GE. debLevB ) THEN
469             myIter = 1
470             CALL PLOT_FIELD_XYRL( XC      , 'Current XC      ' ,
471         &        myIter, myThid )
472             CALL PLOT_FIELD_XYRL( YC      , 'Current YC      ' ,
473         &        myIter, myThid )
474             CALL PLOT_FIELD_XYRL( DXF     , 'Current DXF     ' ,
475         &        myIter, myThid )
476             CALL PLOT_FIELD_XYRL( XC      , 'Current XC      ' ,
477         &        myIter, myThid )
478             CALL PLOT_FIELD_XYRL( DYF     , 'Current DYF     ' ,
479         &        myIter, myThid )
480             CALL PLOT_FIELD_XYRL( RA      , 'Current RA      ' ,
481         &        myIter, myThid )
482             CALL PLOT_FIELD_XYRL( XG      , 'Current XG      ' ,
483         &        myIter, myThid )
484             CALL PLOT_FIELD_XYRL( YG      , 'Current YG      ' ,
485         &        myIter, myThid )
486             CALL PLOT_FIELD_XYRL( DXV     , 'Current DXV     ' ,
487         &        myIter, myThid )
488             CALL PLOT_FIELD_XYRL( DYU     , 'Current DYU     ' ,
489         &        myIter, myThid )
490             CALL PLOT_FIELD_XYRL( RAZ     , 'Current RAZ     ' ,
491         &        myIter, myThid )
492             CALL PLOT_FIELD_XYRL( DXC     , 'Current DXC     ' ,
493         &        myIter, myThid )
494             CALL PLOT_FIELD_XYRL( DYC     , 'Current DYC     ' ,
495         &        myIter, myThid )
496             CALL PLOT_FIELD_XYRL( RAW     , 'Current RAW     ' ,
497         &        myIter, myThid )
498             CALL PLOT_FIELD_XYRL( RAS     , 'Current RAS     ' ,
499         &        myIter, myThid )
500             CALL PLOT_FIELD_XYRL( DXG     , 'Current DXG     ' ,
501         &        myIter, myThid )
502             CALL PLOT_FIELD_XYRL( DYG     , 'Current DYG     ' ,
503         &        myIter, myThid )
504             CALL PLOT_FIELD_XYRL(angleCosC, 'Current AngleCS ' ,
505         &        myIter, myThid )
506             CALL PLOT_FIELD_XYRL(angleSinC, 'Current AngleSN ' ,
507         &        myIter, myThid )
508          ENDIF
509    
510          RETURN
511          END
512    
513    C --------------------------------------------------------------------------
514    
515          SUBROUTINE READSYMTILE_RS(fName,irec,array,bi,bj,buf,myThid)
516    C     /==========================================================\
517    C     | SUBROUTINE READSYMTILE_RS                                |
518    C     |==========================================================|
519    C     \==========================================================/
520          IMPLICIT NONE
521    
522    C     === Global variables ===
523    #include "SIZE.h"
524    #include "EEPARAMS.h"
525    #ifdef ALLOW_EXCH2
526    #include "W2_EXCH2_TOPOLOGY.h"
527    #include "W2_EXCH2_PARAMS.h"
528    #endif /* ALLOW_EXCH2 */
529    
530    C     == Routine arguments ==
531          CHARACTER*(*) fName
532          INTEGER irec
533          _RS array(1-Olx:sNx+Olx,1-Oly:sNy+Oly,nSx,nSy)
534          INTEGER bi,bj,myThid
535    #ifdef ALLOW_EXCH2
536          _RL buf(1:sNx*nSx*nPx+1)
537    #else
538          _RL buf(1:sNx+1,1:sNy+1)
539    #endif /* ALLOW_EXCH2 */
540    
541    C     == Local variables ==
542          INTEGER I,J,dUnit, iLen
543          INTEGER length_of_rec
544          INTEGER MDS_RECLEN
545    #ifdef ALLOW_EXCH2
546          INTEGER TN, dNx, dNy, TBX, TBY, TNX, TNY, II, iBase
547    #endif
548          INTEGER  ILNBLNK
549          EXTERNAL ILNBLNK
550    
551          iLen = ILNBLNK(fName)
552    #ifdef ALLOW_EXCH2
553    C     Figure out offset of tile within face
554          TN  = W2_myTileList(bi)
555          dNx = exch2_mydnx(TN)
556          dNy = exch2_mydny(TN)
557          TBX = exch2_tbasex(TN)
558          TBY = exch2_tbasey(TN)
559          TNX = exch2_tnx(TN)
560          TNY = exch2_tny(TN)
561    
562          CALL MDSFINDUNIT( dUnit, myThid )
563          length_of_rec=MDS_RECLEN( 64, (dNx+1), myThid )
564          OPEN( dUnit, file=fName(1:iLen), status='old',
565         &             access='direct', recl=length_of_rec )
566          J=0
567          iBase=(irec-1)*(dny+1)
568          DO I=1+TBY,sNy+1+TBY
569           READ(dUnit,rec=I+iBase)(buf(ii),ii=1,dNx+1)
570    #ifdef _BYTESWAPIO
571    #ifdef REAL4_IS_SLOW
572           CALL MDS_BYTESWAPR8((dNx+1), buf)
573    #else
574           CALL MDS_BYTESWAPR4((dNx+1), buf)
575    #endif
576    #endif
577           J=J+1
578           DO II=1,sNx+1
579            array(II,J,bi,bj)=buf(II+TBX)
580           ENDDO
581          ENDDO
582          CLOSE( dUnit )
583          
584    #else /* ALLOW_EXCH2 */
585    
586          CALL MDSFINDUNIT( dUnit, myThid )
587          length_of_rec=MDS_RECLEN( 64, (sNx+1)*(sNy+1), myThid )
588          OPEN( dUnit, file=fName(1:iLen), status='old',
589         &             access='direct', recl=length_of_rec )
590          READ(dUnit,rec=irec) buf
591          CLOSE( dUnit )
592    
593    #ifdef _BYTESWAPIO
594    #ifdef REAL4_IS_SLOW
595          CALL MDS_BYTESWAPR8((sNx+1)*(sNy+1), buf)
596    #else
597          CALL MDS_BYTESWAPR4((sNx+1)*(sNy+1), buf)
598    #endif
599    #endif
600    
601          DO J=1,sNy+1
602           DO I=1,sNx+1
603            array(I,J,bi,bj)=buf(I,J)
604           ENDDO
605          ENDDO
606    c       write(0,*) irec,buf(1,1),array(1,1,1,1)
607    
608    #endif /* ALLOW_EXCH2 */
609    
610        RETURN        RETURN
611        END        END
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.26
  ViewVC Help
Powered by ViewVC 1.1.22