/[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.10 - (show annotations) (download)
Thu Oct 23 04:41:40 2003 UTC (20 years, 6 months ago) by edhill
Branch: MAIN
CVS Tags: checkpoint51o_pre, checkpoint51n_post, checkpoint51n_pre, checkpoint51o_post, checkpoint51p_post
Branch point for: checkpoint51n_branch
Changes since 1.9: +4 -0 lines
 o added the [#include "AD_CONFIG.h"] statement to all files that need
   it for adjoint/tl #defines
 o re-worked the build logic in genmake2 to support AD_CONFIG.h
 o removed tools/genmake since it no longer works

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

  ViewVC Help
Powered by ViewVC 1.1.22