/[MITgcm]/MITgcm/pkg/ctrl/ctrl_set_unpack_xz.F
ViewVC logotype

Annotation of /MITgcm/pkg/ctrl/ctrl_set_unpack_xz.F

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


Revision 1.14 - (hide annotations) (download)
Wed Sep 30 16:03:20 2009 UTC (14 years, 8 months ago) by mlosch
Branch: MAIN
CVS Tags: checkpoint62c, checkpoint62a, checkpoint62, checkpoint62b, checkpoint61w, checkpoint61z, checkpoint61x, checkpoint61y
Changes since 1.13: +9 -3 lines
 - make obcs as control parameter work also with useSingleCPUio
 - replace a few sny and snx by Ny and Nx to be consistent with
   ctrl_set_globfld_x/yz.F

1 mlosch 1.14 C $Header: /u/gcmpack/MITgcm/pkg/ctrl/ctrl_set_unpack_xz.F,v 1.13 2008/01/23 22:38:43 heimbach Exp $
2 jmc 1.12 C $Name: $
3 heimbach 1.2
4     #include "CTRL_CPPOPTIONS.h"
5    
6     subroutine ctrl_set_unpack_xz(
7 heimbach 1.3 & cunit, ivartype, fname, masktype, weighttype,
8 heimbach 1.2 & weightfld, nwetglobal, mythid)
9    
10     c ==================================================================
11     c SUBROUTINE ctrl_set_unpack_xz
12     c ==================================================================
13     c
14 heimbach 1.3 c o Unpack the control vector such that land points are filled in.
15     c
16     c o Open boundary packing added :
17     c gebbie@mit.edu, 18-Mar-2003
18     c
19     c changed: heimbach@mit.edu 17-Jun-2003
20     c merged Armin's changes to replace write of
21     c nr * globfld2d by 1 * globfld3d
22     c (ad hoc fix to speed up global I/O)
23 heimbach 1.2 c
24     c ==================================================================
25    
26     implicit none
27    
28     c == global variables ==
29    
30     #include "EEPARAMS.h"
31     #include "SIZE.h"
32     #include "PARAMS.h"
33     #include "GRID.h"
34    
35     #include "ctrl.h"
36     #include "optim.h"
37    
38     c == routine arguments ==
39    
40     integer cunit
41     integer ivartype
42     character*( 80) fname
43     character* (9) masktype
44 heimbach 1.3 character*( 80) weighttype
45 heimbach 1.2 _RL weightfld( nr,nobcs )
46     integer nwetglobal(nr,nobcs)
47     integer mythid
48    
49 heimbach 1.11 #ifndef EXCLUDE_CTRL_PACK
50 heimbach 1.2 c == local variables ==
51    
52 heimbach 1.13 logical lxxadxx
53    
54 heimbach 1.2 integer bi,bj
55     integer ip,jp
56     integer i,j,k
57 heimbach 1.4 integer ii,jj,kk
58 heimbach 1.2 integer il
59 heimbach 1.3 integer irec,iobcs,nrec_nl
60 heimbach 1.2 integer itlo,ithi
61     integer jtlo,jthi
62     integer jmin,jmax
63     integer imin,imax
64    
65     integer cbuffindex
66    
67 heimbach 1.13 real*4 cbuff ( snx*nsx*npx*nsy*npy )
68     real*4 globfldtmp2( snx,nsx,npx,nsy,npy )
69     real*4 globfldtmp3( snx,nsx,npx,nsy,npy )
70 heimbach 1.2 _RL globfldxz( snx,nsx,npx,nsy,npy,nr )
71 heimbach 1.3 _RL globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
72     _RL globmskxz( snx,nsx,npx,nsy,npy,nr,nobcs )
73     #ifdef CTRL_UNPACK_PRECISE
74     _RL weightfldxz( snx,nsx,npx,nsy,npy,nr,nobcs )
75     #endif
76 heimbach 1.2
77     cgg(
78 heimbach 1.13 integer reclen, irectrue
79     integer cunit2, cunit3
80 heimbach 1.2 integer igg
81     _RL gg
82 heimbach 1.3 character*(80) weightname
83 heimbach 1.13 character*(80) cfile2, cfile3
84 heimbach 1.2 cgg)
85    
86     c == external ==
87    
88     integer ilnblnk
89     external ilnblnk
90    
91     cc == end of interface ==
92    
93     jtlo = 1
94     jthi = nsy
95     itlo = 1
96     ithi = nsx
97     jmin = 1
98     jmax = sny
99     imin = 1
100     imax = snx
101    
102 heimbach 1.13 lxxadxx = .TRUE.
103    
104 heimbach 1.2 c Initialise temporary file
105     do k = 1,nr
106     do jp = 1,nPy
107     do bj = jtlo,jthi
108     do ip = 1,nPx
109     do bi = itlo,ithi
110     do i = imin,imax
111 heimbach 1.13 globfldxz (i,bi,ip,bj,jp,k) = 0. _d 0
112     globfldtmp2(i,bi,ip,bj,jp) = 0.
113     globfldtmp3(i,bi,ip,bj,jp) = 0.
114 heimbach 1.3 do iobcs=1,nobcs
115     globmskxz(i,bi,ip,bj,jp,k,iobcs) = 0. _d 0
116     enddo
117     enddo
118     enddo
119     enddo
120     enddo
121     enddo
122     enddo
123     c Initialise temporary file
124     do k = 1,nr
125     do jp = 1,nPy
126     do bj = jtlo,jthi
127     do j = jmin,jmax
128     do ip = 1,nPx
129     do bi = itlo,ithi
130     do i = imin,imax
131     globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
132     enddo
133 heimbach 1.2 enddo
134     enddo
135     enddo
136     enddo
137     enddo
138     enddo
139    
140     c-- Only the master thread will do I/O.
141     _BEGIN_MASTER( mythid )
142    
143 heimbach 1.13 if ( doPackDiag ) then
144     write(cfile2(1:80),'(80a)') ' '
145     write(cfile3(1:80),'(80a)') ' '
146     if ( lxxadxx ) then
147     write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
148     & 'diag_unpack_nondim_ctrl_',
149     & ivartype, '_', optimcycle, '.bin'
150     write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
151     & 'diag_unpack_dimens_ctrl_',
152     & ivartype, '_', optimcycle, '.bin'
153     else
154     write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
155     & 'diag_unpack_nondim_grad_',
156     & ivartype, '_', optimcycle, '.bin'
157     write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
158     & 'diag_unpack_dimens_grad_',
159     & ivartype, '_', optimcycle, '.bin'
160     endif
161    
162     reclen = snx*nsx*npx*nsy*npy*4
163     call mdsfindunit( cunit2, mythid )
164     open( cunit2, file=cfile2, status='unknown',
165     & access='direct', recl=reclen )
166     call mdsfindunit( cunit3, mythid )
167     open( cunit3, file=cfile3, status='unknown',
168     & access='direct', recl=reclen )
169     endif
170    
171 heimbach 1.3 do iobcs=1,nobcs
172 jmc 1.12 call MDSREADFIELD_XZ_GL(
173 heimbach 1.3 & masktype, ctrlprec, 'RL',
174     & Nr, globmskxz(1,1,1,1,1,1,iobcs), iobcs,mythid)
175     #ifdef CTRL_UNPACK_PRECISE
176     il=ilnblnk( weighttype)
177     write(weightname(1:80),'(80a)') ' '
178     write(weightname(1:80),'(a)') weighttype(1:il)
179     call MDSREADFIELD_XZ_GL(
180     & weightname, ctrlprec, 'RL',
181     & Nr, weightfldxz(1,1,1,1,1,1,iobcs), iobcs, mythid)
182     CGG One special exception: barotropic velocity should be nondimensionalized
183     cgg differently. Probably introduce new variable.
184     if (iobcs .eq. 3 .or. iobcs .eq. 4) then
185     k = 1
186     do jp = 1,nPy
187     do bj = jtlo,jthi
188     do ip = 1,nPx
189     do bi = itlo,ithi
190     do i = imin,imax
191 heimbach 1.10 cph weightfldxz(i,bi,ip,bj,jp,k,iobcs) = wbaro
192 heimbach 1.3 enddo
193     enddo
194     enddo
195     enddo
196     enddo
197     endif
198     #endif /* CTRL_UNPACK_PRECISE */
199     enddo
200    
201 mlosch 1.14 if ( useSingleCPUio ) then
202     C MDSWRITEFIELD_XZ_GL does not know about useSingleCPUio, so the faster
203     C method that works for .not.useSingleCPUio cannot be used
204     nrec_nl = 0
205     else
206     nrec_nl = int(ncvarrecs(ivartype)/Ny)
207     endif
208 heimbach 1.3 do irec = 1, nrec_nl
209 heimbach 1.2 cgg do iobcs = 1, nobcs
210 heimbach 1.3 cgg And now back-calculate what iobcs should be.
211     do j=1,sny
212     iobcs= mod((irec-1)*sny+j-1,nobcs)+1
213 jmc 1.12
214 heimbach 1.3 read(cunit) filencvarindex(ivartype)
215     if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
216     & then
217     print *, 'ctrl-set_unpack:xz:WARNING: wrong ncvarindex ',
218     & filencvarindex(ivartype), ncvarindex(ivartype)
219     STOP 'in S/R ctrl_unpack'
220     endif
221     read(cunit) filej
222     read(cunit) filei
223     do k = 1, Nr
224 heimbach 1.13 irectrue = (irec-1)*nobcs*nr + (iobcs-1)*nr + k
225 heimbach 1.3 cbuffindex = nwetglobal(k,iobcs)
226     if ( cbuffindex .gt. 0 ) then
227     read(cunit) filencbuffindex
228     if (filencbuffindex .NE. cbuffindex) then
229     print *, 'WARNING: wrong cbuffindex ',
230     & filencbuffindex, cbuffindex
231     STOP 'in S/R ctrl_unpack'
232     endif
233     read(cunit) filek
234     if (filek .NE. k) then
235     print *, 'WARNING: wrong k ',
236     & filek, k
237     STOP 'in S/R ctrl_unpack'
238     endif
239     read(cunit) (cbuff(ii), ii=1,cbuffindex)
240     endif
241 heimbach 1.13
242 heimbach 1.3 cbuffindex = 0
243 heimbach 1.7 jj=mod((j-1)*nr+k-1,sny)+1
244     kk=int((j-1)*nr+k-1)/sny+1
245 heimbach 1.3 do jp = 1,nPy
246     do bj = jtlo,jthi
247     do ip = 1,nPx
248     do bi = itlo,ithi
249     do i = imin,imax
250     if ( globmskxz(i,bi,ip,bj,jp,k,iobcs) .ne. 0. ) then
251     cbuffindex = cbuffindex + 1
252 jmc 1.12 globfld3d(i,bi,ip,jj,bj,jp,kk) =
253 heimbach 1.4 & cbuff(cbuffindex)
254 heimbach 1.13 cph(
255     globfldtmp2(i,bi,ip,bj,jp) =
256     & cbuff(cbuffindex)
257     cph)
258 heimbach 1.3 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
259 jmc 1.12 globfld3d(i,bi,ip,jj,bj,jp,kk) =
260 heimbach 1.4 & globfld3d(i,bi,ip,jj,bj,jp,kk)/
261 heimbach 1.3 # ifdef CTRL_UNPACK_PRECISE
262     & sqrt(weightfldxz(i,bi,ip,bj,jp,k,iobcs))
263     # else
264     & sqrt(weightfld(k,iobcs))
265     # endif
266     #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
267     else
268 heimbach 1.4 globfld3d(i,bi,ip,jj,bj,jp,kk) = 0. _d 0
269 heimbach 1.3 endif
270 heimbach 1.13 cph(
271     globfldtmp3(i,bi,ip,bj,jp) =
272     & globfld3d(i,bi,ip,jj,bj,jp,kk)
273     cph)
274 heimbach 1.3 enddo
275     enddo
276     enddo
277     enddo
278     enddo
279     c
280 heimbach 1.13 if ( doPackDiag ) then
281     write(cunit2,rec=irectrue) globfldtmp2
282     write(cunit3,rec=irectrue) globfldtmp3
283     endif
284     c
285 heimbach 1.3 c -- end of k loop --
286     enddo
287     c -- end of j loop --
288     enddo
289 jmc 1.12
290 heimbach 1.3 call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',
291     & Nr, globfld3d, irec,
292     & optimcycle, mythid)
293    
294     c -- end of iobcs loop -- This loop removed. 3-28-02.
295     cgg enddo
296     c -- end of irec loop --
297     enddo
298 heimbach 1.2
299 mlosch 1.14 do irec = nrec_nl*ny+1, ncvarrecs(ivartype)
300 heimbach 1.3 cgg do iobcs = 1, nobcs
301     cgg And now back-calculate what iobcs should be.
302     iobcs= mod(irec-1,nobcs)+1
303 heimbach 1.2
304     read(cunit) filencvarindex(ivartype)
305     if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
306     & then
307     print *, 'ctrl-set_unpack:xz:WARNING: wrong ncvarindex ',
308     & filencvarindex(ivartype), ncvarindex(ivartype)
309     STOP 'in S/R ctrl_unpack'
310     endif
311     read(cunit) filej
312     read(cunit) filei
313     do k = 1, Nr
314 heimbach 1.13 irectrue = (irec-1)*nobcs*nr + (iobcs-1)*nr + k
315 heimbach 1.2 cbuffindex = nwetglobal(k,iobcs)
316     if ( cbuffindex .gt. 0 ) then
317     read(cunit) filencbuffindex
318     if (filencbuffindex .NE. cbuffindex) then
319     print *, 'WARNING: wrong cbuffindex ',
320     & filencbuffindex, cbuffindex
321     STOP 'in S/R ctrl_unpack'
322     endif
323     read(cunit) filek
324     if (filek .NE. k) then
325     print *, 'WARNING: wrong k ',
326     & filek, k
327     STOP 'in S/R ctrl_unpack'
328     endif
329     read(cunit) (cbuff(ii), ii=1,cbuffindex)
330     endif
331 heimbach 1.13
332 heimbach 1.2 cbuffindex = 0
333     do jp = 1,nPy
334     do bj = jtlo,jthi
335     do ip = 1,nPx
336     do bi = itlo,ithi
337     do i = imin,imax
338 heimbach 1.3 if ( globmskxz(i,bi,ip,bj,jp,k,iobcs) .ne. 0. ) then
339 heimbach 1.2 cbuffindex = cbuffindex + 1
340     globfldxz(i,bi,ip,bj,jp,k) = cbuff(cbuffindex)
341 heimbach 1.13 cph(
342     globfldtmp2(i,bi,ip,bj,jp) = cbuff(cbuffindex)
343     cph)
344 heimbach 1.2 #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
345 jmc 1.12 globfldxz(i,bi,ip,bj,jp,k) =
346 heimbach 1.2 & globfldxz(i,bi,ip,bj,jp,k)/
347 heimbach 1.3 # ifdef CTRL_UNPACK_PRECISE
348     & sqrt(weightfldxz(i,bi,ip,bj,jp,k,iobcs))
349     # else
350 heimbach 1.2 & sqrt(weightfld(k,iobcs))
351 heimbach 1.3 # endif
352     #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
353 heimbach 1.2 else
354     globfldxz(i,bi,ip,bj,jp,k) = 0. _d 0
355     endif
356 heimbach 1.13 cph(
357     globfldtmp3(i,bi,ip,bj,jp) =
358     & globfldxz(i,bi,ip,bj,jp,k)
359     cph)
360 heimbach 1.2 enddo
361     enddo
362     enddo
363     enddo
364     enddo
365     c
366 heimbach 1.13 if ( doPackDiag ) then
367     write(cunit2,rec=irectrue) globfldtmp2
368     write(cunit3,rec=irectrue) globfldtmp3
369     endif
370     c
371 heimbach 1.3 c -- end of k loop --
372 heimbach 1.2 enddo
373 jmc 1.12
374 heimbach 1.2 call MDSWRITEFIELD_XZ_GL( fname, ctrlprec, 'RL',
375     & Nr, globfldxz, irec,
376     & optimcycle, mythid)
377    
378     c -- end of iobcs loop -- This loop removed. 3-28-02.
379     cgg enddo
380     c -- end of irec loop --
381     enddo
382    
383     _END_MASTER( mythid )
384    
385 heimbach 1.11 #endif
386    
387 heimbach 1.2 return
388     end
389    
390    
391    
392    
393    

  ViewVC Help
Powered by ViewVC 1.1.22