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

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

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


Revision 1.21 - (hide annotations) (download)
Tue Oct 9 00:00:01 2007 UTC (16 years, 8 months ago) by jmc
Branch: MAIN
CVS Tags: checkpoint62c, checkpoint62a, checkpoint60, checkpoint61, checkpoint62, checkpoint59q, checkpoint59p, checkpoint59r, checkpoint59m, checkpoint59l, checkpoint59o, checkpoint59n, checkpoint59i, checkpoint59k, checkpoint62b, checkpoint61f, checkpoint61n, checkpoint59j, checkpoint61q, checkpoint61e, checkpoint61g, checkpoint61d, checkpoint61b, checkpoint61c, checkpoint61a, checkpoint61o, checkpoint61l, checkpoint61m, checkpoint61j, checkpoint61k, checkpoint61h, checkpoint61i, checkpoint61v, checkpoint61w, checkpoint61t, checkpoint61u, checkpoint61r, checkpoint61s, checkpoint61p, checkpoint61z, checkpoint61x, checkpoint61y
Changes since 1.20: +18 -16 lines
add missing cvs $Header:$ or $Name:$

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

  ViewVC Help
Powered by ViewVC 1.1.22