/[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.20 - (hide annotations) (download)
Tue Jun 19 03:42:30 2007 UTC (18 years ago) by gforget
Branch: MAIN
CVS Tags: checkpoint59e, checkpoint59d, checkpoint59g, checkpoint59f, checkpoint59h
Changes since 1.19: +28 -0 lines
pkg/smooth application to control vector

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

  ViewVC Help
Powered by ViewVC 1.1.22