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

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

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


Revision 1.5 - (hide annotations) (download)
Sat Jul 13 02:47:32 2002 UTC (21 years, 11 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint46n_post, checkpoint46l_post, checkpoint46g_pre, checkpoint46f_post, checkpoint46b_post, checkpoint46l_pre, checkpoint47a_post, checkpoint46d_pre, checkpoint46j_pre, checkpoint46a_post, checkpoint46j_post, checkpoint46k_post, checkpoint46e_pre, checkpoint46b_pre, checkpoint46c_pre, checkpoint46, checkpoint46h_pre, checkpoint46m_post, checkpoint46a_pre, checkpoint46g_post, checkpoint46i_post, checkpoint46c_post, checkpoint46e_post, checkpoint47, checkpoint46h_post, checkpoint46d_post
Changes since 1.4: +283 -1165 lines
Merging new ctrl package from release1_p5:
o new ctrl package
  - adopted from ECCO environment to enable optimization
  - added Eliassen Palm fluxes to controls

1 heimbach 1.1
2     #include "CTRL_CPPOPTIONS.h"
3    
4 heimbach 1.4 CBOP
5     C !ROUTINE: ctrl_pack
6     C !INTERFACE:
7     subroutine ctrl_pack( myiter, mytime, mythid )
8    
9     C !DESCRIPTION: \bv
10     c *=================================================================
11     c | SUBROUTINE ctrl_pack
12     c | Pack the control vector
13     c | * All control variable and adjoint variable fields are
14     c | read from disk.
15     c | * Wet points are extracted, and elements are
16     c | normalized (optional)
17     c | * A single control vector containing only (normalized
18     c | wet points is written to file.
19     c *=================================================================
20     C \ev
21 heimbach 1.1
22 heimbach 1.4 C !USES:
23 heimbach 1.1 implicit none
24    
25     c == global variables ==
26 heimbach 1.5
27 heimbach 1.1 #include "EEPARAMS.h"
28     #include "SIZE.h"
29     #include "PARAMS.h"
30     #include "GRID.h"
31 heimbach 1.5
32     #include "ecco.h"
33 heimbach 1.1 #include "ctrl.h"
34     #include "cost.h"
35 heimbach 1.5
36     #ifdef ALLOW_ECCO_OPTIMIZATION
37 heimbach 1.2 #include "optim.h"
38 heimbach 1.5 #endif
39 heimbach 1.1
40     c == routine arguments ==
41 heimbach 1.5
42 heimbach 1.1 integer myiter
43     _RL mytime
44     integer mythid
45    
46     c == local variables ==
47    
48 heimbach 1.5 #ifndef ALLOW_ECCO_OPTIMIZATION
49     integer optimcycle
50     #endif
51    
52     integer i, j, k
53 heimbach 1.1 integer ii
54     integer il
55     integer irec
56 heimbach 1.5 integer ig,jg
57     integer ivartype
58     integer iobcs
59 heimbach 1.1
60     logical doglobalread
61     logical ladinit
62 heimbach 1.5 integer cbuffindex
63 heimbach 1.1
64 heimbach 1.5 integer cunit
65 heimbach 1.1 _RL tmpvar
66    
67     character*(128) cfile
68 heimbach 1.5 character*( 80) weighttype
69    
70     character*( 80) fname_theta
71     character*( 80) fname_salt
72     character*( 80) fname_hflux
73     character*( 80) fname_sflux
74     character*( 80) fname_tauu
75     character*( 80) fname_tauv
76     character*( 80) adfname_theta
77     character*( 80) adfname_salt
78     character*( 80) adfname_hflux
79     character*( 80) adfname_sflux
80     character*( 80) adfname_tauu
81     character*( 80) adfname_tauv
82     character*( 80) fname_atemp
83     character*( 80) adfname_atemp
84     character*( 80) fname_aqh
85     character*( 80) adfname_aqh
86     character*( 80) fname_uwind
87     character*( 80) adfname_uwind
88     character*( 80) fname_vwind
89     character*( 80) adfname_vwind
90     character*( 80) fname_obcsn
91     character*( 80) adfname_obcsn
92     character*( 80) fname_obcss
93     character*( 80) adfname_obcss
94     character*( 80) fname_obcsw
95     character*( 80) adfname_obcsw
96     character*( 80) fname_obcse
97     character*( 80) adfname_obcse
98     character*( 80) fname_diffkr
99     character*( 80) adfname_diffkr
100     character*( 80) fname_kapgm
101     character*( 80) adfname_kapgm
102     character*( 80) fname_tr1
103     character*( 80) adfname_tr1
104     character*( 80) fname_efluxy
105     character*( 80) adfname_efluxy
106     character*( 80) fname_efluxp
107     character*( 80) adfname_efluxp
108    
109     logical lxxadxx
110 heimbach 1.1
111     c == external ==
112 heimbach 1.5
113 heimbach 1.1 integer ilnblnk
114     external ilnblnk
115    
116     c == end of interface ==
117    
118 heimbach 1.5 #ifndef ALLOW_ECCO_OPTIMIZATION
119     optimcycle = 0
120     #endif
121 heimbach 1.1
122 heimbach 1.5 tmpvar = -9999. _d 0
123 heimbach 1.1
124     c-- Tiled files are used.
125     doglobalread = .false.
126    
127     c-- Initialise adjoint variables on active files.
128     ladinit = .false.
129    
130 heimbach 1.5 c-- Assign file names.
131    
132     call ctrl_set_fname(
133     I xx_theta_file, fname_theta, adfname_theta, mythid )
134     call ctrl_set_fname(
135     I xx_salt_file, fname_salt, adfname_salt, mythid )
136     call ctrl_set_fname(
137     I xx_hflux_file, fname_hflux, adfname_hflux, mythid )
138     call ctrl_set_fname(
139     I xx_sflux_file, fname_sflux, adfname_sflux, mythid )
140     call ctrl_set_fname(
141     I xx_tauu_file, fname_tauu, adfname_tauu, mythid )
142     call ctrl_set_fname(
143     I xx_tauv_file, fname_tauv, adfname_tauv, mythid )
144     call ctrl_set_fname(
145     I xx_atemp_file, fname_atemp, adfname_atemp, mythid )
146     call ctrl_set_fname(
147     I xx_aqh_file, fname_aqh, adfname_aqh, mythid )
148     call ctrl_set_fname(
149     I xx_uwind_file, fname_uwind, adfname_uwind, mythid )
150     call ctrl_set_fname(
151     I xx_vwind_file, fname_vwind, adfname_vwind, mythid )
152     call ctrl_set_fname(
153     I xx_obcsn_file, fname_obcsn, adfname_obcsn, mythid )
154     call ctrl_set_fname(
155     I xx_obcss_file, fname_obcss, adfname_obcss, mythid )
156     call ctrl_set_fname(
157     I xx_obcsw_file, fname_obcsw, adfname_obcsw, mythid )
158     call ctrl_set_fname(
159     I xx_obcse_file, fname_obcse, adfname_obcse, mythid )
160     call ctrl_set_fname(
161     I xx_diffkr_file, fname_diffkr, adfname_diffkr, mythid )
162     call ctrl_set_fname(
163     I xx_kapgm_file, fname_kapgm, adfname_kapgm, mythid )
164     call ctrl_set_fname(
165     I xx_tr1_file, fname_tr1, adfname_tr1, mythid )
166     call ctrl_set_fname(
167     I xx_efluxy_file, fname_efluxy, adfname_efluxy, mythid )
168     call ctrl_set_fname(
169     I xx_efluxp_file, fname_efluxp, adfname_efluxp, mythid )
170    
171 heimbach 1.1 c
172 heimbach 1.5 c-- Only the master thread will do I/O.
173 heimbach 1.1 _BEGIN_MASTER( mythid )
174    
175     c >>> Write control vector <<<
176    
177 heimbach 1.5 cph this part was removed since it's not necessary
178     cph and causes huge amounts of wall clock time on parallel machines
179 heimbach 1.2
180    
181 heimbach 1.1
182     c >>> Write gradient vector <<<
183 heimbach 1.5 lxxadxx = .FALSE.
184 heimbach 1.1
185     call mdsfindunit( cunit, mythid )
186 heimbach 1.5 write(cfile(1:128),'(4a,i4.4)')
187     & costname(1:9),'_',yctrlid(1:10),'.opt',
188 heimbach 1.1 & optimcycle
189    
190     open( cunit, file = cfile,
191     & status = 'unknown',
192     & form = 'unformatted',
193     & access = 'sequential' )
194    
195     c-- Header information.
196     write(cunit) nvartype
197     write(cunit) nvarlength
198 heimbach 1.5 write(cunit) yctrlid
199 heimbach 1.1 write(cunit) optimCycle
200     write(cunit) fc
201     write(cunit) 1
202     write(cunit) 1
203     write(cunit) 1
204     write(cunit) 1
205 heimbach 1.5 write(cunit) (nWetcGlobal(k), k=1,nr)
206     write(cunit) (nWetsGlobal(k), k=1,nr)
207     write(cunit) (nWetwGlobal(k), k=1,nr)
208     write(cunit) (nWetvGlobal(k), k=1,nr)
209     #ifdef ALLOW_OBCSN_CONTROL
210     write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
211     #endif
212     #ifdef ALLOW_OBCSS_CONTROL
213     write(cunit) ((nWetobcssGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
214     #endif
215     #ifdef ALLOW_OBCSW_CONTROL
216     write(cunit) ((nWetobcswGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
217     #endif
218     #ifdef ALLOW_OBCSE_CONTROL
219     write(cunit) ((nWetobcseGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
220     #endif
221 heimbach 1.1 write(cunit) (ncvarindex(i), i=1,maxcvars)
222     write(cunit) (ncvarrecs(i), i=1,maxcvars)
223     write(cunit) (nx, i=1,maxcvars)
224     write(cunit) (ny, i=1,maxcvars)
225     write(cunit) (ncvarnrmax(i), i=1,maxcvars)
226     write(cunit) (ncvargrd(i), i=1,maxcvars)
227     write(cunit)
228    
229     #ifdef ALLOW_THETA0_CONTROL
230 heimbach 1.5 ivartype = 1
231     call ctrl_set_pack_xyz(
232     & cunit, ivartype, adfname_theta, "hFacC",
233     & wtheta, lxxadxx, mythid)
234 heimbach 1.1 #endif
235    
236     #ifdef ALLOW_SALT0_CONTROL
237 heimbach 1.5 ivartype = 2
238     call ctrl_set_pack_xyz(
239     & cunit, ivartype, adfname_salt, "hFacC",
240     & wsalt, lxxadxx, mythid)
241     #endif
242    
243     #if (defined (ALLOW_HFLUX_CONTROL) || \
244     defined (ALLOW_HFLUX0_CONTROL))
245     ivartype = 3
246     write(weighttype(1:80),'(80a)') ' '
247     write(weighttype(1:80),'(a)') "whflux"
248     call ctrl_set_pack_xy(
249     & cunit, ivartype, adfname_hflux, "hFacC", weighttype,
250     & lxxadxx, mythid)
251     #endif
252    
253     #if (defined (ALLOW_SFLUX_CONTROL) || \
254     defined (ALLOW_SFLUX0_CONTROL))
255     ivartype = 4
256     write(weighttype(1:80),'(80a)') ' '
257     write(weighttype(1:80),'(a)') "wsflux"
258     call ctrl_set_pack_xy(
259     & cunit, ivartype, adfname_sflux, "hFacC", weighttype,
260     & lxxadxx, mythid)
261     #endif
262    
263     #if (defined (ALLOW_USTRESS_CONTROL) || \
264     defined (ALLOW_TAUU0_CONTROL))
265     ivartype = 5
266     write(weighttype(1:80),'(80a)') ' '
267     write(weighttype(1:80),'(a)') "wtauu"
268     call ctrl_set_pack_xy(
269     & cunit, ivartype, adfname_tauu, "maskW", weighttype,
270     & lxxadxx, mythid)
271     #endif
272    
273     #if (defined (ALLOW_VSTRESS_CONTROL) || \
274     defined (ALLOW_TAUV0_CONTROL))
275     ivartype = 6
276     write(weighttype(1:80),'(80a)') ' '
277     write(weighttype(1:80),'(a)') "wtauv"
278     call ctrl_set_pack_xy(
279     & cunit, ivartype, adfname_tauv, "maskS", weighttype,
280     & lxxadxx, mythid)
281     #endif
282    
283     #ifdef ALLOW_ATEMP_CONTROL
284     ivartype = 7
285     write(weighttype(1:80),'(80a)') ' '
286     write(weighttype(1:80),'(a)') "watemp"
287     call ctrl_set_pack_xy(
288     & cunit, ivartype, adfname_atemp, "hFacC", weighttype,
289     & lxxadxx, mythid)
290     #endif
291    
292     #ifdef ALLOW_AQH_CONTROL
293     ivartype = 8
294     write(weighttype(1:80),'(80a)') ' '
295     write(weighttype(1:80),'(a)') "waqh"
296     call ctrl_set_pack_xy(
297     & cunit, ivartype, adfname_aqh, "hFacC", weighttype,
298     & lxxadxx, mythid)
299     #endif
300    
301     #ifdef ALLOW_UWIND_CONTROL
302     ivartype = 9
303     write(weighttype(1:80),'(80a)') ' '
304     write(weighttype(1:80),'(a)') "wuwind"
305     call ctrl_set_pack_xy(
306     & cunit, ivartype, adfname_uwind, "maskW", weighttype,
307     & lxxadxx, mythid)
308     #endif
309    
310     #ifdef ALLOW_VWIND_CONTROL
311     ivartype = 10
312     write(weighttype(1:80),'(80a)') ' '
313     write(weighttype(1:80),'(a)') "wvwind"
314     call ctrl_set_pack_xy(
315     & cunit, ivartype, adfname_vwind, "maskS", weighttype,
316     & lxxadxx, mythid)
317     #endif
318    
319     #ifdef ALLOW_OBCSN_CONTROL
320     ivartype = 11
321     call ctrl_set_pack_xz(
322     & cunit, ivartype, adfname_obcsn, "maskobcsn",
323     & wobcsn, lxxadxx, mythid)
324     #endif
325    
326     #ifdef ALLOW_OBCSS_CONTROL
327     ivartype = 12
328     call ctrl_set_pack_xz(
329     & cunit, ivartype, adfname_obcss, "maskobcss",
330     & wobcss, lxxadxx, mythid)
331     #endif
332    
333     #ifdef ALLOW_OBCSW_CONTROL
334     ivartype = 13
335     call ctrl_set_pack_yz(
336     & cunit, ivartype, adfname_obcsw, "maskobcsw",
337     & wobcsw, lxxadxx, mythid)
338     #endif
339    
340     #ifdef ALLOW_OBCSE_CONTROL
341     ivartype = 14
342     call ctrl_set_pack_yz(
343     & cunit, ivartype, adfname_obcse, "maskobcse",
344     & wobcse, lxxadxx, mythid)
345 heimbach 1.1 #endif
346 heimbach 1.3
347     #ifdef ALLOW_DIFFKR_CONTROL
348 heimbach 1.5 ivartype = 15
349     call ctrl_set_pack_xyz(
350     & cunit, ivartype, adfname_diffkr, "hFacC",
351     & wunit, lxxadxx, mythid)
352 heimbach 1.3 #endif
353    
354     #ifdef ALLOW_KAPGM_CONTROL
355 heimbach 1.5 ivartype = 16
356     call ctrl_set_pack_xyz(
357     & cunit, ivartype, adfname_kapgm, "hFacC",
358     & wunit, lxxadxx, mythid)
359 heimbach 1.3 #endif
360    
361 heimbach 1.5 #ifdef ALLOW_TR10_CONTROL
362     ivartype = 17
363     call ctrl_set_pack_xyz(
364     & cunit, ivartype, adfname_tr1, "hFacC",
365     & wunit, lxxadxx, mythid)
366     #endif
367    
368     cph(
369     print *, 'ph-nondim bef. vor 21'
370     print *, 'ph-nondim aft. vor 21'
371     cph)
372     #ifdef ALLOW_EFLUXY0_CONTROL
373     ivartype = 21
374     call ctrl_set_pack_xyz(
375     & cunit, ivartype, adfname_efluxy, "hFacS",
376     & wefluxy, lxxadxx, mythid)
377     #endif
378    
379     cph(
380     print *, 'ph-nondim bef. vor 22'
381     print *, 'ph-nondim aft. vor 22'
382     cph)
383     #ifdef ALLOW_EFLUXP0_CONTROL
384     ivartype = 22
385     call ctrl_set_pack_xyz(
386     & cunit, ivartype, adfname_efluxp, "hFacV",
387     & wefluxp, lxxadxx, mythid)
388     #endif
389    
390     cph(
391     print *, 'ph-nondim bef. ende'
392     print *, 'ph-nondim aft. ende'
393     cph)
394     close ( cunit )
395 heimbach 1.1
396 heimbach 1.5 _END_MASTER( mythid )
397 heimbach 1.1
398     return
399     end
400    

  ViewVC Help
Powered by ViewVC 1.1.22