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

Contents of /MITgcm/pkg/ctrl/ctrl_pack.F

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


Revision 1.8 - (show annotations) (download)
Tue Jun 24 16:07:07 2003 UTC (20 years, 11 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint51, checkpoint51d_post, checkpoint51b_pre, checkpoint51b_post, checkpoint51c_post, checkpoint51a_post
Changes since 1.7: +69 -35 lines
Merging for c51 vs. e34

1
2 #include "CTRL_CPPOPTIONS.h"
3
4
5 subroutine ctrl_pack(
6 I myiter,
7 I mytime,
8 I mythid
9 & )
10
11 c ==================================================================
12 c SUBROUTINE ctrl_pack
13 c ==================================================================
14 c
15 c o Compress the control vector such that only ocean points are
16 c written to file.
17 c
18 c started: Christian Eckert eckert@mit.edu 10-Mar=2000
19 c
20 c changed: Patrick Heimbach heimbach@mit.edu 06-Jun-2000
21 c - Transferred some filename declarations
22 c from here to namelist in ctrl_init
23 c
24 c Patrick Heimbach heimbach@mit.edu 16-Jun-2000
25 c - single file name convention with or without
26 c ALLOW_ECCO_OPTIMIZATION
27 c
28 c G. Gebbie, added open boundary control packing,
29 c gebbie@mit.edu 18 -Mar- 2003
30 c
31 c ==================================================================
32 c SUBROUTINE ctrl_pack
33 c ==================================================================
34
35 implicit none
36
37 c == global variables ==
38
39 #include "EEPARAMS.h"
40 #include "SIZE.h"
41 #include "PARAMS.h"
42 #include "GRID.h"
43
44 #include "ecco.h"
45 #include "ctrl.h"
46 #include "cost.h"
47
48 #ifdef ALLOW_ECCO_OPTIMIZATION
49 #include "optim.h"
50 #endif
51
52 c == routine arguments ==
53
54 integer myiter
55 _RL mytime
56 integer mythid
57
58 c == local variables ==
59
60 #ifndef ALLOW_ECCO_OPTIMIZATION
61 integer optimcycle
62 #endif
63
64 integer i, j, k
65 integer ii
66 integer il
67 integer irec
68 integer ig,jg
69 integer ivartype
70 integer iobcs
71
72 logical doglobalread
73 logical ladinit
74 integer cbuffindex
75
76 integer cunit
77 _RL tmpvar
78
79 character*(128) cfile
80 character*( 80) weighttype
81
82 character*( 80) fname_theta
83 character*( 80) fname_salt
84 character*( 80) fname_hflux
85 character*( 80) fname_sflux
86 character*( 80) fname_tauu
87 character*( 80) fname_tauv
88 character*( 80) adfname_theta
89 character*( 80) adfname_salt
90 character*( 80) adfname_hflux
91 character*( 80) adfname_sflux
92 character*( 80) adfname_tauu
93 character*( 80) adfname_tauv
94 character*( 80) fname_atemp
95 character*( 80) adfname_atemp
96 character*( 80) fname_aqh
97 character*( 80) adfname_aqh
98 character*( 80) fname_uwind
99 character*( 80) adfname_uwind
100 character*( 80) fname_vwind
101 character*( 80) adfname_vwind
102 character*( 80) fname_obcsn
103 character*( 80) adfname_obcsn
104 character*( 80) fname_obcss
105 character*( 80) adfname_obcss
106 character*( 80) fname_obcsw
107 character*( 80) adfname_obcsw
108 character*( 80) fname_obcse
109 character*( 80) adfname_obcse
110 character*( 80) fname_diffkr
111 character*( 80) adfname_diffkr
112 character*( 80) fname_kapgm
113 character*( 80) adfname_kapgm
114 character*( 80) fname_tr1
115 character*( 80) adfname_tr1
116 character*( 80) fname_sst
117 character*( 80) adfname_sst
118 character*( 80) fname_sss
119 character*( 80) adfname_sss
120 character*( 80) fname_hfacc
121 character*( 80) adfname_hfacc
122 character*( 80) fname_efluxy
123 character*( 80) adfname_efluxy
124 character*( 80) fname_efluxp
125 character*( 80) adfname_efluxp
126 character*( 80) fname_bottomdrag
127 character*( 80) adfname_bottomdrag
128
129 logical lxxadxx
130
131 c == external ==
132
133 integer ilnblnk
134 external ilnblnk
135
136 c == end of interface ==
137
138 #ifndef ALLOW_ECCO_OPTIMIZATION
139 optimcycle = 0
140 #endif
141
142 tmpvar = -9999. _d 0
143
144 c-- Tiled files are used.
145 doglobalread = .false.
146
147 c-- Initialise adjoint variables on active files.
148 ladinit = .false.
149
150 c-- Assign file names.
151
152 call ctrl_set_fname(
153 I xx_theta_file, fname_theta, adfname_theta, mythid )
154 call ctrl_set_fname(
155 I xx_salt_file, fname_salt, adfname_salt, mythid )
156 call ctrl_set_fname(
157 I xx_hflux_file, fname_hflux, adfname_hflux, mythid )
158 call ctrl_set_fname(
159 I xx_sflux_file, fname_sflux, adfname_sflux, mythid )
160 call ctrl_set_fname(
161 I xx_tauu_file, fname_tauu, adfname_tauu, mythid )
162 call ctrl_set_fname(
163 I xx_tauv_file, fname_tauv, adfname_tauv, mythid )
164 call ctrl_set_fname(
165 I xx_atemp_file, fname_atemp, adfname_atemp, mythid )
166 call ctrl_set_fname(
167 I xx_aqh_file, fname_aqh, adfname_aqh, mythid )
168 call ctrl_set_fname(
169 I xx_uwind_file, fname_uwind, adfname_uwind, mythid )
170 call ctrl_set_fname(
171 I xx_vwind_file, fname_vwind, adfname_vwind, mythid )
172 call ctrl_set_fname(
173 I xx_obcsn_file, fname_obcsn, adfname_obcsn, mythid )
174 call ctrl_set_fname(
175 I xx_obcss_file, fname_obcss, adfname_obcss, mythid )
176 call ctrl_set_fname(
177 I xx_obcsw_file, fname_obcsw, adfname_obcsw, mythid )
178 call ctrl_set_fname(
179 I xx_obcse_file, fname_obcse, adfname_obcse, mythid )
180 call ctrl_set_fname(
181 I xx_diffkr_file, fname_diffkr, adfname_diffkr, mythid )
182 call ctrl_set_fname(
183 I xx_kapgm_file, fname_kapgm, adfname_kapgm, mythid )
184 call ctrl_set_fname(
185 I xx_tr1_file, fname_tr1, adfname_tr1, mythid )
186 call ctrl_set_fname(
187 I xx_sst_file, fname_sst, adfname_sst, mythid )
188 call ctrl_set_fname(
189 I xx_sss_file, fname_sss, adfname_sss, mythid )
190 call ctrl_set_fname(
191 I xx_hfacc_file, fname_hfacc, adfname_hfacc, mythid )
192 call ctrl_set_fname(
193 I xx_efluxy_file, fname_efluxy, adfname_efluxy, mythid )
194 call ctrl_set_fname(
195 I xx_efluxp_file, fname_efluxp, adfname_efluxp, mythid )
196 call ctrl_set_fname(
197 I xx_bottomdrag_file, fname_bottomdrag, adfname_bottomdrag
198 I , mythid )
199
200 c
201 c-- Only the master thread will do I/O.
202 _BEGIN_MASTER( mythid )
203
204 c >>> Write control vector <<<
205
206 cph this part was removed since it's not necessary
207 cph and causes huge amounts of wall clock time on parallel machines
208
209
210
211 c >>> Write gradient vector <<<
212 lxxadxx = .FALSE.
213
214 call mdsfindunit( cunit, mythid )
215 write(cfile(1:128),'(4a,i4.4)')
216 & costname(1:9),'_',yctrlid(1:10),'.opt',
217 & optimcycle
218
219 open( cunit, file = cfile,
220 & status = 'unknown',
221 & form = 'unformatted',
222 & access = 'sequential' )
223
224 c-- Header information.
225 write(cunit) nvartype
226 write(cunit) nvarlength
227 write(cunit) yctrlid
228 write(cunit) optimCycle
229 write(cunit) fc
230 write(cunit) 1
231 write(cunit) 1
232 write(cunit) 1
233 write(cunit) 1
234 write(cunit) (nWetcGlobal(k), k=1,nr)
235 write(cunit) (nWetsGlobal(k), k=1,nr)
236 write(cunit) (nWetwGlobal(k), k=1,nr)
237 #ifdef ALLOW_CTRL_WETV
238 write(cunit) (nWetvGlobal(k), k=1,nr)
239 #endif
240 #ifdef ALLOW_OBCSN_CONTROL
241 write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
242 #endif
243 #ifdef ALLOW_OBCSS_CONTROL
244 write(cunit) ((nWetobcssGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
245 #endif
246 #ifdef ALLOW_OBCSW_CONTROL
247 write(cunit) ((nWetobcswGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
248 #endif
249 #ifdef ALLOW_OBCSE_CONTROL
250 write(cunit) ((nWetobcseGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
251 #endif
252 write(cunit) (ncvarindex(i), i=1,maxcvars)
253 write(cunit) (ncvarrecs(i), i=1,maxcvars)
254 write(cunit) (nx, i=1,maxcvars)
255 write(cunit) (ny, i=1,maxcvars)
256 write(cunit) (ncvarnrmax(i), i=1,maxcvars)
257 write(cunit) (ncvargrd(i), i=1,maxcvars)
258 write(cunit)
259
260 #ifdef ALLOW_THETA0_CONTROL
261 ivartype = 1
262 write(weighttype(1:80),'(80a)') ' '
263 write(weighttype(1:80),'(a)') "wtheta"
264 call ctrl_set_pack_xyz(
265 & cunit, ivartype, adfname_theta, "hFacC",
266 & weighttype, wtheta, lxxadxx, mythid)
267 #endif
268
269 #ifdef ALLOW_SALT0_CONTROL
270 ivartype = 2
271 write(weighttype(1:80),'(80a)') ' '
272 write(weighttype(1:80),'(a)') "wsalt"
273 call ctrl_set_pack_xyz(
274 & cunit, ivartype, adfname_salt, "hFacC",
275 & weighttype, wsalt, lxxadxx, mythid)
276 #endif
277
278 #if (defined (ALLOW_HFLUX_CONTROL) || \
279 defined (ALLOW_HFLUX0_CONTROL))
280 ivartype = 3
281 write(weighttype(1:80),'(80a)') ' '
282 write(weighttype(1:80),'(a)') "whflux"
283 call ctrl_set_pack_xy(
284 & cunit, ivartype, adfname_hflux, "hFacC", weighttype,
285 & lxxadxx, mythid)
286 #endif
287
288 #if (defined (ALLOW_SFLUX_CONTROL) || \
289 defined (ALLOW_SFLUX0_CONTROL))
290 ivartype = 4
291 write(weighttype(1:80),'(80a)') ' '
292 write(weighttype(1:80),'(a)') "wsflux"
293 call ctrl_set_pack_xy(
294 & cunit, ivartype, adfname_sflux, "hFacC", weighttype,
295 & lxxadxx, mythid)
296 #endif
297
298 #if (defined (ALLOW_USTRESS_CONTROL) || \
299 defined (ALLOW_TAUU0_CONTROL))
300 ivartype = 5
301 write(weighttype(1:80),'(80a)') ' '
302 write(weighttype(1:80),'(a)') "wtauu"
303 call ctrl_set_pack_xy(
304 & cunit, ivartype, adfname_tauu, "maskW", weighttype,
305 & lxxadxx, mythid)
306 #endif
307
308 #if (defined (ALLOW_VSTRESS_CONTROL) || \
309 defined (ALLOW_TAUV0_CONTROL))
310 ivartype = 6
311 write(weighttype(1:80),'(80a)') ' '
312 write(weighttype(1:80),'(a)') "wtauv"
313 call ctrl_set_pack_xy(
314 & cunit, ivartype, adfname_tauv, "maskS", weighttype,
315 & lxxadxx, mythid)
316 #endif
317
318 #ifdef ALLOW_ATEMP_CONTROL
319 ivartype = 7
320 write(weighttype(1:80),'(80a)') ' '
321 write(weighttype(1:80),'(a)') "watemp"
322 call ctrl_set_pack_xy(
323 & cunit, ivartype, adfname_atemp, "hFacC", weighttype,
324 & lxxadxx, mythid)
325 #endif
326
327 #ifdef ALLOW_AQH_CONTROL
328 ivartype = 8
329 write(weighttype(1:80),'(80a)') ' '
330 write(weighttype(1:80),'(a)') "waqh"
331 call ctrl_set_pack_xy(
332 & cunit, ivartype, adfname_aqh, "hFacC", weighttype,
333 & lxxadxx, mythid)
334 #endif
335
336 #ifdef ALLOW_UWIND_CONTROL
337 ivartype = 9
338 write(weighttype(1:80),'(80a)') ' '
339 write(weighttype(1:80),'(a)') "wuwind"
340 call ctrl_set_pack_xy(
341 & cunit, ivartype, adfname_uwind, "maskW", weighttype,
342 & lxxadxx, mythid)
343 #endif
344
345 #ifdef ALLOW_VWIND_CONTROL
346 ivartype = 10
347 write(weighttype(1:80),'(80a)') ' '
348 write(weighttype(1:80),'(a)') "wvwind"
349 call ctrl_set_pack_xy(
350 & cunit, ivartype, adfname_vwind, "maskS", weighttype,
351 & lxxadxx, mythid)
352 #endif
353
354 #ifdef ALLOW_OBCSN_CONTROL
355 ivartype = 11
356 write(weighttype(1:80),'(80a)') ' '
357 write(weighttype(1:80),'(a)') "wobcsn"
358 call ctrl_set_pack_xz(
359 & cunit, ivartype, adfname_obcsn, "maskobcsn",
360 & weighttype, wobcsn, lxxadxx, mythid)
361 #endif
362
363 #ifdef ALLOW_OBCSS_CONTROL
364 ivartype = 12
365 write(weighttype(1:80),'(80a)') ' '
366 write(weighttype(1:80),'(a)') "wobcss"
367 call ctrl_set_pack_xz(
368 & cunit, ivartype, adfname_obcss, "maskobcss",
369 & weighttype, wobcss, lxxadxx, mythid)
370 #endif
371
372 #ifdef ALLOW_OBCSW_CONTROL
373 ivartype = 13
374 write(weighttype(1:80),'(80a)') ' '
375 write(weighttype(1:80),'(a)') "wobcsw"
376 call ctrl_set_pack_yz(
377 & cunit, ivartype, adfname_obcsw, "maskobcsw",
378 & weighttype, wobcsw, lxxadxx, mythid)
379 #endif
380
381 #ifdef ALLOW_OBCSE_CONTROL
382 ivartype = 14
383 write(weighttype(1:80),'(80a)') ' '
384 write(weighttype(1:80),'(a)') "wobcse"
385 call ctrl_set_pack_yz(
386 & cunit, ivartype, adfname_obcse, "maskobcse",
387 & weighttype, wobcse, lxxadxx, mythid)
388 #endif
389
390 #ifdef ALLOW_DIFFKR_CONTROL
391 ivartype = 15
392 write(weighttype(1:80),'(80a)') ' '
393 write(weighttype(1:80),'(a)') "wdiffkr"
394 call ctrl_set_pack_xyz(
395 & cunit, ivartype, adfname_diffkr, "hFacC",
396 & weighttype, wunit, lxxadxx, mythid)
397 #endif
398
399 #ifdef ALLOW_KAPGM_CONTROL
400 ivartype = 16
401 write(weighttype(1:80),'(80a)') ' '
402 write(weighttype(1:80),'(a)') "wkapgm"
403 call ctrl_set_pack_xyz(
404 & cunit, ivartype, adfname_kapgm, "hFacC",
405 & weighttype, wunit, lxxadxx, mythid)
406 #endif
407
408 #ifdef ALLOW_TR10_CONTROL
409 ivartype = 17
410 write(weighttype(1:80),'(80a)') ' '
411 write(weighttype(1:80),'(a)') "wtr1"
412 call ctrl_set_pack_xyz(
413 & cunit, ivartype, adfname_tr1, "hFacC",
414 & weighttype, wunit, lxxadxx, mythid)
415 #endif
416
417 #ifdef ALLOW_SST0_CONTROL
418 ivartype = 18
419 write(weighttype(1:80),'(80a)') ' '
420 write(weighttype(1:80),'(a)') "wsst0"
421 call ctrl_set_pack_xy(
422 & cunit, ivartype, adfname_sst0, "hFacC", weighttype,
423 & lxxadxx, mythid)
424 #endif
425
426 #ifdef ALLOW_SSS0_CONTROL
427 ivartype = 19
428 write(weighttype(1:80),'(80a)') ' '
429 write(weighttype(1:80),'(a)') "wsss0"
430 call ctrl_set_pack_xy(
431 & cunit, ivartype, adfname_sss0, "hFacC", weighttype,
432 & lxxadxx, mythid)
433 #endif
434
435 #ifdef ALLOW_HFACC_CONTROL
436 ivartype = 20
437 write(weighttype(1:80),'(80a)') ' '
438 write(weighttype(1:80),'(a)') "whfacc"
439 # ifdef ALLOW_HFACC3D_CONTROL
440 call ctrl_set_pack_xyz(
441 & cunit, ivartype, adfname_hfacc, "hFacC",
442 & weighttype, wunit, lxxadxx, mythid)
443 # else
444 call ctrl_set_pack_xy(
445 & cunit, ivartype, adfname_hfacc, "hFacC", weighttype,
446 & lxxadxx, mythid)
447 # endif
448 #endif
449
450 #ifdef ALLOW_EFLUXY0_CONTROL
451 ivartype = 21
452 write(weighttype(1:80),'(80a)') ' '
453 write(weighttype(1:80),'(a)') "wefluxy0"
454 call ctrl_set_pack_xyz(
455 & cunit, ivartype, adfname_efluxy, "hFacS",
456 & weighttype, wunit, lxxadxx, mythid)
457 #endif
458
459 #ifdef ALLOW_EFLUXP0_CONTROL
460 ivartype = 22
461 write(weighttype(1:80),'(80a)') ' '
462 write(weighttype(1:80),'(a)') "wefluxp0"
463 call ctrl_set_pack_xyz(
464 & cunit, ivartype, adfname_efluxp, "hFacV",
465 & weighttype, wunit, lxxadxx, mythid)
466 #endif
467
468 #ifdef ALLOW_BOTTOMDRAG_CONTROL
469 ivartype = 23
470 write(weighttype(1:80),'(80a)') ' '
471 write(weighttype(1:80),'(a)') "wbottomdrag"
472 call ctrl_set_pack_xy(
473 & cunit, ivartype, adfname_bottomdrag, "hFacC", weighttype,
474 & lxxadxx, mythid)
475 #endif
476
477 close ( cunit )
478
479 _END_MASTER( mythid )
480
481 return
482 end
483

  ViewVC Help
Powered by ViewVC 1.1.22