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

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

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

revision 1.25 by heimbach, Wed Sep 7 02:45:12 2005 UTC revision 1.50 by heimbach, Fri Feb 1 19:25:32 2013 UTC
# Line 1  Line 1 
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3    
4  #include "PACKAGES_CONFIG.h"  #include "CTRL_OPTIONS.h"
5  #include "CTRL_CPPOPTIONS.h"  #ifdef ALLOW_EXF
6    # include "EXF_OPTIONS.h"
7    #endif
8    
9        subroutine ctrl_pack( first, mythid )        subroutine ctrl_pack( first, mythid )
10    
# Line 18  c Line 20  c
20  c     changed: Patrick Heimbach heimbach@mit.edu 06-Jun-2000  c     changed: Patrick Heimbach heimbach@mit.edu 06-Jun-2000
21  c              - Transferred some filename declarations  c              - Transferred some filename declarations
22  c                from here to namelist in ctrl_init  c                from here to namelist in ctrl_init
23  c    c
24  c              Patrick Heimbach heimbach@mit.edu 16-Jun-2000  c              Patrick Heimbach heimbach@mit.edu 16-Jun-2000
25  c              - single file name convention with or without  c              - single file name convention with or without
26  c                ALLOW_ECCO_OPTIMIZATION  c                ALLOW_ECCO_OPTIMIZATION
# Line 42  c     == global variables == Line 44  c     == global variables ==
44  #include "GRID.h"  #include "GRID.h"
45    
46  #include "ctrl.h"  #include "ctrl.h"
47    #include "CTRL_SIZE.h"
48    #include "CTRL_GENARR.h"
49  #include "optim.h"  #include "optim.h"
50    
51  #ifdef ALLOW_COST  #ifdef ALLOW_COST
# Line 52  c     == global variables == Line 56  c     == global variables ==
56  #else  #else
57  # include "ctrl_weights.h"  # include "ctrl_weights.h"
58  #endif  #endif
59    #ifdef ALLOW_EXF
60    # include "EXF_PARAM.h"
61    #endif
62    
63  c     == routine arguments ==  c     == routine arguments ==
   
64        logical first        logical first
65        integer mythid        integer mythid
66    
67  #ifndef EXCLUDE_CTRL_PACK  #ifndef EXCLUDE_CTRL_PACK
68    c     == external ==
69          integer  ilnblnk
70          external ilnblnk
71    
72  c     == local variables ==  c     == local variables ==
73    
74        _RL    fcloc        _RL    fcloc
# Line 70  c     == local variables == Line 80  c     == local variables ==
80        integer ig,jg        integer ig,jg
81        integer ivartype        integer ivartype
82        integer iobcs        integer iobcs
83    #if (defined ALLOW_GENARR2D_CONTROL) || (defined ALLOW_GENARR3D_CONTROL) || (defined ALLOW_GENTIM2D_CONTROL)
84    C-    Provided we set the file name just before calling ctrl_set_pack,
85    C     the same local file name variable can be used for different variables.
86    C     This is how GENARR2/3D_CONTROL is implemented (+ provides an example)
87          integer iarr
88          character*(80) fname_local(3)
89    #endif
90    
91        logical doglobalread        logical doglobalread
92        logical ladinit        logical ladinit
93        integer cbuffindex        integer cbuffindex
94        logical lxxadxx        logical lxxadxx
95          
96        integer cunit        integer cunit
97        integer ictrlgrad        integer ictrlgrad
98    
99        character*(128) cfile        character*(128) cfile
100        character*( 80) weighttype        character*( 80) weighttype
101    
 c     == external ==  
   
       integer  ilnblnk  
       external ilnblnk  
   
102  c     == end of interface ==  c     == end of interface ==
103    
104  #ifndef ALLOW_ECCO_OPTIMIZATION  #ifndef ALLOW_ECCO_OPTIMIZATION
# Line 115  c--   Assign file names. Line 127  c--   Assign file names.
127        call ctrl_set_fname(xx_precip_file, fname_precip, mythid)        call ctrl_set_fname(xx_precip_file, fname_precip, mythid)
128        call ctrl_set_fname(xx_swflux_file, fname_swflux, mythid)        call ctrl_set_fname(xx_swflux_file, fname_swflux, mythid)
129        call ctrl_set_fname(xx_swdown_file, fname_swdown, mythid)        call ctrl_set_fname(xx_swdown_file, fname_swdown, mythid)
130          call ctrl_set_fname(xx_lwflux_file, fname_lwflux, mythid)
131          call ctrl_set_fname(xx_lwdown_file, fname_lwdown, mythid)
132          call ctrl_set_fname(xx_evap_file, fname_evap, mythid)
133          call ctrl_set_fname(xx_snowprecip_file, fname_snowprecip, mythid)
134          call ctrl_set_fname(xx_apressure_file, fname_apressure, mythid)
135          call ctrl_set_fname(xx_runoff_file, fname_runoff, mythid)
136        call ctrl_set_fname(xx_uwind_file, fname_uwind, mythid)        call ctrl_set_fname(xx_uwind_file, fname_uwind, mythid)
137        call ctrl_set_fname(xx_vwind_file, fname_vwind, mythid)        call ctrl_set_fname(xx_vwind_file, fname_vwind, mythid)
138        call ctrl_set_fname(xx_obcsn_file, fname_obcsn, mythid)        call ctrl_set_fname(xx_obcsn_file, fname_obcsn, mythid)
# Line 123  c--   Assign file names. Line 141  c--   Assign file names.
141        call ctrl_set_fname(xx_obcse_file, fname_obcse, mythid)        call ctrl_set_fname(xx_obcse_file, fname_obcse, mythid)
142        call ctrl_set_fname(xx_diffkr_file, fname_diffkr, mythid)        call ctrl_set_fname(xx_diffkr_file, fname_diffkr, mythid)
143        call ctrl_set_fname(xx_kapgm_file, fname_kapgm, mythid)        call ctrl_set_fname(xx_kapgm_file, fname_kapgm, mythid)
144          call ctrl_set_fname(xx_kapredi_file, fname_kapredi, mythid)
145        call ctrl_set_fname(xx_tr1_file, fname_tr1, mythid)        call ctrl_set_fname(xx_tr1_file, fname_tr1, mythid)
146        call ctrl_set_fname(xx_sst_file, fname_sst, mythid)        call ctrl_set_fname(xx_sst_file, fname_sst, mythid)
147        call ctrl_set_fname(xx_sss_file, fname_sss, mythid)        call ctrl_set_fname(xx_sss_file, fname_sss, mythid)
148        call ctrl_set_fname(xx_hfacc_file, fname_hfacc, mythid)        call ctrl_set_fname(xx_depth_file, fname_depth, mythid)
149        call ctrl_set_fname(xx_efluxy_file, fname_efluxy, mythid)        call ctrl_set_fname(xx_efluxy_file, fname_efluxy, mythid)
150        call ctrl_set_fname(xx_efluxp_file, fname_efluxp, mythid)        call ctrl_set_fname(xx_efluxp_file, fname_efluxp, mythid)
151        call ctrl_set_fname(xx_bottomdrag_file, fname_bottomdrag, mythid)        call ctrl_set_fname(xx_bottomdrag_file, fname_bottomdrag, mythid)
# Line 137  c--   Assign file names. Line 156  c--   Assign file names.
156        call ctrl_set_fname(xx_etan_file, fname_etan, mythid)        call ctrl_set_fname(xx_etan_file, fname_etan, mythid)
157        call ctrl_set_fname(xx_relaxsst_file, fname_relaxsst, mythid)        call ctrl_set_fname(xx_relaxsst_file, fname_relaxsst, mythid)
158        call ctrl_set_fname(xx_relaxsss_file, fname_relaxsss, mythid)        call ctrl_set_fname(xx_relaxsss_file, fname_relaxsss, mythid)
159          call ctrl_set_fname(xx_siarea_file, fname_siarea, mythid)
160          call ctrl_set_fname(xx_siheff_file, fname_siheff, mythid)
161          call ctrl_set_fname(xx_sihsnow_file, fname_sihsnow, mythid)
162          call ctrl_set_fname(xx_shifwflx_file, fname_shifwflx, mythid)
163    cHFLUXM_CONTROL
164          call ctrl_set_fname(xx_hfluxm_file, fname_hfluxm, mythid)
165    cHFLUXM_CONTROL
166    
167  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
168        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
# Line 147  c     >>> Initialise control vector for Line 173  c     >>> Initialise control vector for
173            ictrlgrad = 1            ictrlgrad = 1
174            fcloc     = fmin            fcloc     = fmin
175            write(cfile(1:128),'(4a,i4.4)')            write(cfile(1:128),'(4a,i4.4)')
176       &         ctrlname(1:9),'_',yctrlid(1:10),       &         ctrlname(1:9),'_',yctrlid(1:10),
177       &         yctrlpospack, optimcycle       &         yctrlpospack, optimcycle
178            print *, 'ph-pack: packing ', ctrlname(1:9)            print *, 'ph-pack: packing ', ctrlname(1:9)
179        else        else
180  c     >>> Write gradient vector <<<  c     >>> Write gradient vector <<<
181            lxxadxx   = .FALSE.            lxxadxx   = .FALSE.
182            ictrlgrad = 2            ictrlgrad = 2
183    #ifdef ALLOW_AUTODIFF_OPENAD
184              fcloc     = fc%v
185    #else
186            fcloc     = fc            fcloc     = fc
187    #endif
188            write(cfile(1:128),'(4a,i4.4)')            write(cfile(1:128),'(4a,i4.4)')
189       &         costname(1:9),'_',yctrlid(1:10),       &         costname(1:9),'_',yctrlid(1:10),
190       &         yctrlpospack, optimcycle       &         yctrlpospack, optimcycle
191            print *, 'ph-pack: packing ', costname(1:9)            print *, 'ph-pack: packing ', costname(1:9)
192         endif         endif
193    
194    c--   Only Proc 0 will do I/O.
195          IF ( myProcId .eq. 0 ) THEN
196    
197         call mdsfindunit( cunit, mythid )         call mdsfindunit( cunit, mythid )
198         open( cunit, file   = cfile,         open( cunit, file   = cfile,
199       &      status = 'unknown',       &      status = 'unknown',
# Line 185  C     place holder of obsolete variable Line 218  C     place holder of obsolete variable
218  #ifdef ALLOW_CTRL_WETV  #ifdef ALLOW_CTRL_WETV
219            write(cunit) (nWetvGlobal(k), k=1,nr)            write(cunit) (nWetvGlobal(k), k=1,nr)
220  #endif  #endif
221    #ifdef ALLOW_SHIFWFLX_CONTROL
222              write(cunit) (nWetiGlobal(k), k=1,nr)
223    c          write(cunit) nWetiGlobal(1)
224    #endif
225    
226  #ifdef ALLOW_OBCSN_CONTROL  #ifdef ALLOW_OBCSN_CONTROL
227            write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)            write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
# Line 206  C     place holder of obsolete variable Line 243  C     place holder of obsolete variable
243            write(cunit) (ncvargrd(i),   i=1,maxcvars)            write(cunit) (ncvargrd(i),   i=1,maxcvars)
244            write(cunit)            write(cunit)
245    
246    #ifdef ALLOW_PACKUNPACK_METHOD2
247          ENDIF
248          _END_MASTER( mythid )
249          _BARRIER
250    #endif
251    
252  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
253            ivartype = 1            ivartype = 1
254            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
255            write(weighttype(1:80),'(a)') "wtheta"            write(weighttype(1:80),'(a)') "wthetaLev"
256            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
257       &         cunit, ivartype, fname_theta(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, fname_theta(ictrlgrad), "maskCtrlC",
258       &         weighttype, wtheta, lxxadxx, mythid)       &         weighttype, wtheta, lxxadxx, mythid)
# Line 218  C     place holder of obsolete variable Line 261  C     place holder of obsolete variable
261  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
262            ivartype = 2            ivartype = 2
263            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
264            write(weighttype(1:80),'(a)') "wsalt"            write(weighttype(1:80),'(a)') "wsaltLev"
265            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
266       &         cunit, ivartype, fname_salt(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, fname_salt(ictrlgrad), "maskCtrlC",
267       &         weighttype, wsalt, lxxadxx, mythid)       &         weighttype, wsalt, lxxadxx, mythid)
# Line 229  C     place holder of obsolete variable Line 272  C     place holder of obsolete variable
272            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
273            write(weighttype(1:80),'(a)') "whflux"            write(weighttype(1:80),'(a)') "whflux"
274            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
275       &         cunit, ivartype, fname_hflux(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
276         &         fname_hflux(ictrlgrad), "maskCtrlC",
277       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
278  #endif  #endif
279    
# Line 238  C     place holder of obsolete variable Line 282  C     place holder of obsolete variable
282            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
283            write(weighttype(1:80),'(a)') "wsflux"            write(weighttype(1:80),'(a)') "wsflux"
284            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
285       &         cunit, ivartype, fname_sflux(ictrlgrad), "maskCtrlC",       &         cunit, ivartype,  forcingPrecond,
286         &         fname_sflux(ictrlgrad), "maskCtrlC",
287       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
288  #endif  #endif
289    
290  #if (defined (ALLOW_USTRESS_CONTROL) || defined (ALLOW_TAUU0_CONTROL))  #if (defined (ALLOW_USTRESS_CONTROL) || defined (ALLOW_TAUU0_CONTROL))
291    #ifdef ALLOW_EXF
292          IF ( .NOT.useAtmWind ) THEN
293    #endif
294            ivartype = 5            ivartype = 5
295            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
296            write(weighttype(1:80),'(a)') "wtauu"            write(weighttype(1:80),'(a)') "wtauu"
297            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
298       &         cunit, ivartype, fname_tauu(ictrlgrad), "maskCtrlW",  #ifndef ALLOW_ROTATE_UV_CONTROLS
299         &         cunit, ivartype, forcingPrecond,
300         &         fname_tauu(ictrlgrad), "maskCtrlW",
301    #else
302         &         cunit, ivartype, forcingPrecond,
303         &         fname_tauu(ictrlgrad), "maskCtrlC",
304    #endif
305       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
306    #ifdef ALLOW_EXF
307          ENDIF
308    #endif
309  #endif  #endif
310    
311  #if (defined (ALLOW_VSTRESS_CONTROL) || defined (ALLOW_TAUV0_CONTROL))  #if (defined (ALLOW_VSTRESS_CONTROL) || defined (ALLOW_TAUV0_CONTROL))
312    #ifdef ALLOW_EXF
313          IF ( .NOT.useAtmWind ) THEN
314    #endif
315            ivartype = 6            ivartype = 6
316            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
317            write(weighttype(1:80),'(a)') "wtauv"            write(weighttype(1:80),'(a)') "wtauv"
318            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
319       &         cunit, ivartype, fname_tauv(ictrlgrad), "maskCtrlS",  #ifndef ALLOW_ROTATE_UV_CONTROLS
320         &         cunit, ivartype, forcingPrecond,
321         &         fname_tauv(ictrlgrad), "maskCtrlS",
322    #else
323         &         cunit, ivartype, forcingPrecond,
324         &         fname_tauv(ictrlgrad), "maskCtrlC",
325    #endif
326       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
327    #ifdef ALLOW_EXF
328          ENDIF
329    #endif
330  #endif  #endif
331    
332  #ifdef ALLOW_ATEMP_CONTROL  #ifdef ALLOW_ATEMP_CONTROL
# Line 265  C     place holder of obsolete variable Line 334  C     place holder of obsolete variable
334            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
335            write(weighttype(1:80),'(a)') "watemp"            write(weighttype(1:80),'(a)') "watemp"
336            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
337       &         cunit, ivartype, fname_atemp(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
338         &         fname_atemp(ictrlgrad), "maskCtrlC",
339       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
340  #endif  #endif
341    
# Line 274  C     place holder of obsolete variable Line 344  C     place holder of obsolete variable
344            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
345            write(weighttype(1:80),'(a)') "waqh"            write(weighttype(1:80),'(a)') "waqh"
346            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
347       &         cunit, ivartype, fname_aqh(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
348         &         fname_aqh(ictrlgrad), "maskCtrlC",
349       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
350  #endif  #endif
351    
352  #ifdef ALLOW_UWIND_CONTROL  #ifdef ALLOW_UWIND_CONTROL
353    #ifdef ALLOW_EXF
354          IF ( useAtmWind ) THEN
355    #endif
356            ivartype = 9            ivartype = 9
357            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
358            write(weighttype(1:80),'(a)') "wuwind"            write(weighttype(1:80),'(a)') "wuwind"
359            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
360       &         cunit, ivartype, fname_uwind(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
361         &         fname_uwind(ictrlgrad), "maskCtrlC",
362       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
363    #ifdef ALLOW_EXF
364          ENDIF
365    #endif
366  #endif  #endif
367    
368  #ifdef ALLOW_VWIND_CONTROL  #ifdef ALLOW_VWIND_CONTROL
369    #ifdef ALLOW_EXF
370          IF ( useAtmWind ) THEN
371    #endif
372            ivartype = 10            ivartype = 10
373            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
374            write(weighttype(1:80),'(a)') "wvwind"            write(weighttype(1:80),'(a)') "wvwind"
375            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
376       &         cunit, ivartype, fname_vwind(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
377         &         fname_vwind(ictrlgrad), "maskCtrlC",
378       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
379    #ifdef ALLOW_EXF
380          ENDIF
381    #endif
382  #endif  #endif
383    
384  #ifdef ALLOW_OBCSN_CONTROL  #ifdef ALLOW_OBCSN_CONTROL
# Line 338  C     place holder of obsolete variable Line 423  C     place holder of obsolete variable
423            write(weighttype(1:80),'(a)') "wdiffkr"            write(weighttype(1:80),'(a)') "wdiffkr"
424            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
425       &         cunit, ivartype, fname_diffkr(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, fname_diffkr(ictrlgrad), "maskCtrlC",
426       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wdiffkr, lxxadxx, mythid)
427  #endif  #endif
428    
429  #ifdef ALLOW_KAPGM_CONTROL  #ifdef ALLOW_KAPGM_CONTROL
# Line 347  C     place holder of obsolete variable Line 432  C     place holder of obsolete variable
432            write(weighttype(1:80),'(a)') "wkapgm"            write(weighttype(1:80),'(a)') "wkapgm"
433            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
434       &         cunit, ivartype, fname_kapgm(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, fname_kapgm(ictrlgrad), "maskCtrlC",
435       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wkapgm, lxxadxx, mythid)
436  #endif  #endif
437    
438  #ifdef ALLOW_TR10_CONTROL  #ifdef ALLOW_TR10_CONTROL
# Line 364  C     place holder of obsolete variable Line 449  C     place holder of obsolete variable
449            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
450            write(weighttype(1:80),'(a)') "wsst"            write(weighttype(1:80),'(a)') "wsst"
451            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
452       &         cunit, ivartype, fname_sst(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
453         &         fname_sst(ictrlgrad), "maskCtrlC",
454       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
455  #endif  #endif
456    
# Line 373  C     place holder of obsolete variable Line 459  C     place holder of obsolete variable
459            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
460            write(weighttype(1:80),'(a)') "wsss"            write(weighttype(1:80),'(a)') "wsss"
461            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
462       &         cunit, ivartype, fname_sss(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
463       &         weighttype, lxxadxx, mythid)       &         fname_sss(ictrlgrad),
464         &         "maskCtrlC", weighttype, lxxadxx, mythid)
465  #endif  #endif
466    
467  #ifdef ALLOW_HFACC_CONTROL  #ifdef ALLOW_DEPTH_CONTROL
468            ivartype = 20            ivartype = 20
469            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
470            write(weighttype(1:80),'(a)') "whfacc"            write(weighttype(1:80),'(a)') "wdepth"
 # ifdef ALLOW_HFACC3D_CONTROL  
           call ctrl_set_pack_xyz(  
      &         cunit, ivartype, fname_hfacc(ictrlgrad), "maskCtrlC",  
      &         weighttype, wunit, lxxadxx, mythid)  
 # else  
471            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
472       &         cunit, ivartype, fname_hfacc(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
473       &         weighttype, lxxadxx, mythid)       &         fname_depth(ictrlgrad),
474  # endif       &         "maskCtrlC", weighttype, lxxadxx, mythid)
475  #endif  #endif /* ALLOW_DEPTH_CONTROL */
476    
477  #ifdef ALLOW_EFLUXY0_CONTROL  #ifdef ALLOW_EFLUXY0_CONTROL
478            ivartype = 21            ivartype = 21
# Line 415  C     place holder of obsolete variable Line 497  C     place holder of obsolete variable
497            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
498            write(weighttype(1:80),'(a)') "wbottomdrag"            write(weighttype(1:80),'(a)') "wbottomdrag"
499            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
500       &      cunit, ivartype, fname_bottomdrag(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
501       &      weighttype, lxxadxx, mythid)       &         fname_bottomdrag(ictrlgrad), "maskCtrlC",
502         &         weighttype, lxxadxx, mythid)
503    #endif
504    
505    #ifdef ALLOW_HFLUXM_CONTROL
506              ivartype = 24
507              write(weighttype(1:80),'(80a)') ' '
508              write(weighttype(1:80),'(a)') "whfluxm"
509              call ctrl_set_pack_xy(
510         &         cunit, ivartype, forcingPrecond,
511         &         fname_hfluxm(ictrlgrad), "maskCtrlC",
512         &         weighttype, lxxadxx, mythid)
513  #endif  #endif
514    
515  #ifdef ALLOW_EDTAUX_CONTROL  #ifdef ALLOW_EDDYPSI_CONTROL
516            ivartype = 25            ivartype = 25
517            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
518            write(weighttype(1:80),'(a)') "wedtaux"            write(weighttype(1:80),'(a)') "wedtaux"
519            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
520       &         cunit, ivartype, fname_edtaux(ictrlgrad), "maskCtrlW",       &         cunit, ivartype, fname_edtaux(ictrlgrad), "maskCtrlW",
521       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wedtaux, lxxadxx, mythid)
 #endif  
522    
 #ifdef ALLOW_EDTAUY_CONTROL  
523            ivartype = 26            ivartype = 26
524            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
525            write(weighttype(1:80),'(a)') "wedtauy"            write(weighttype(1:80),'(a)') "wedtauy"
526            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
527       &         cunit, ivartype, fname_edtauy(ictrlgrad), "maskCtrlS",       &         cunit, ivartype, fname_edtauy(ictrlgrad), "maskCtrlS",
528       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wedtauy, lxxadxx, mythid)
529  #endif  #endif
530    
531  #ifdef ALLOW_UVEL0_CONTROL  #ifdef ALLOW_UVEL0_CONTROL
# Line 443  C     place holder of obsolete variable Line 534  C     place holder of obsolete variable
534            write(weighttype(1:80),'(a)') "wuvel"            write(weighttype(1:80),'(a)') "wuvel"
535            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
536       &         cunit, ivartype, fname_uvel(ictrlgrad), "maskCtrlW",       &         cunit, ivartype, fname_uvel(ictrlgrad), "maskCtrlW",
537       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wuvel, lxxadxx, mythid)
538  #endif  #endif
539    
540  #ifdef ALLOW_VVEL0_CONTROL  #ifdef ALLOW_VVEL0_CONTROL
# Line 452  C     place holder of obsolete variable Line 543  C     place holder of obsolete variable
543            write(weighttype(1:80),'(a)') "wvvel"            write(weighttype(1:80),'(a)') "wvvel"
544            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
545       &         cunit, ivartype, fname_vvel(ictrlgrad), "maskCtrlS",       &         cunit, ivartype, fname_vvel(ictrlgrad), "maskCtrlS",
546       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wvvel, lxxadxx, mythid)
547  #endif  #endif
548    
549  #ifdef ALLOW_ETAN0_CONTROL  #ifdef ALLOW_ETAN0_CONTROL
# Line 460  C     place holder of obsolete variable Line 551  C     place holder of obsolete variable
551            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
552            write(weighttype(1:80),'(a)') "wetan"            write(weighttype(1:80),'(a)') "wetan"
553            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
554       &         cunit, ivartype, fname_etan(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
555       &         weighttype, lxxadxx, mythid)       &         fname_etan(ictrlgrad),
556         &         "maskCtrlC", weighttype, lxxadxx, mythid)
557  #endif  #endif
558    
559  #ifdef ALLOW_RELAXSST_CONTROL  #ifdef ALLOW_RELAXSST_CONTROL
# Line 469  C     place holder of obsolete variable Line 561  C     place holder of obsolete variable
561            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
562            write(weighttype(1:80),'(a)') "wrelaxsst"            write(weighttype(1:80),'(a)') "wrelaxsst"
563            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
564       &         cunit, ivartype, fname_relaxsst(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
565       &         weighttype, lxxadxx, mythid)       &         fname_relaxsst(ictrlgrad),
566         &         "maskCtrlC", weighttype, lxxadxx, mythid)
567  #endif  #endif
568    
569  #ifdef ALLOW_RELAXSSS_CONTROL  #ifdef ALLOW_RELAXSSS_CONTROL
# Line 478  C     place holder of obsolete variable Line 571  C     place holder of obsolete variable
571            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
572            write(weighttype(1:80),'(a)') "wrelaxsss"            write(weighttype(1:80),'(a)') "wrelaxsss"
573            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
574       &         cunit, ivartype, fname_relaxsss(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
575       &         weighttype, lxxadxx, mythid)       &         fname_relaxsss(ictrlgrad),
576         &         "maskCtrlC", weighttype, lxxadxx, mythid)
577  #endif  #endif
578    
579  #ifdef ALLOW_PRECIP_CONTROL  #ifdef ALLOW_PRECIP_CONTROL
# Line 487  C     place holder of obsolete variable Line 581  C     place holder of obsolete variable
581            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
582            write(weighttype(1:80),'(a)') "wprecip"            write(weighttype(1:80),'(a)') "wprecip"
583            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
584       &         cunit, ivartype, fname_precip(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
585       &         weighttype, lxxadxx, mythid)       &         fname_precip(ictrlgrad),
586         &         "maskCtrlC", weighttype, lxxadxx, mythid)
587  #endif  #endif
588    
589  #ifdef ALLOW_SWFLUX_CONTROL  #ifdef ALLOW_SWFLUX_CONTROL
# Line 496  C     place holder of obsolete variable Line 591  C     place holder of obsolete variable
591            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
592            write(weighttype(1:80),'(a)') "wswflux"            write(weighttype(1:80),'(a)') "wswflux"
593            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
594       &         cunit, ivartype, fname_swflux(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
595       &         weighttype, lxxadxx, mythid)       &         fname_swflux(ictrlgrad),
596         &         "maskCtrlC", weighttype, lxxadxx, mythid)
597  #endif  #endif
598    
599  #ifdef ALLOW_SWDOWN_CONTROL  #ifdef ALLOW_SWDOWN_CONTROL
# Line 505  C     place holder of obsolete variable Line 601  C     place holder of obsolete variable
601            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
602            write(weighttype(1:80),'(a)') "wswdown"            write(weighttype(1:80),'(a)') "wswdown"
603            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
604       &         cunit, ivartype, fname_swdown(ictrlgrad), "maskCtrlC",       &         cunit, ivartype, forcingPrecond,
605       &         weighttype, lxxadxx, mythid)       &         fname_swdown(ictrlgrad),
606         &         "maskCtrlC", weighttype, lxxadxx, mythid)
607    #endif
608    
609    #ifdef ALLOW_LWFLUX_CONTROL
610              ivartype = 35
611              write(weighttype(1:80),'(80a)') ' '
612              write(weighttype(1:80),'(a)') "wlwflux"
613              call ctrl_set_pack_xy(
614         &         cunit, ivartype, forcingPrecond,
615         &         fname_lwflux(ictrlgrad),
616         &         "maskCtrlC", weighttype, lxxadxx, mythid)
617    #endif
618    
619    #ifdef ALLOW_LWDOWN_CONTROL
620              ivartype = 36
621              write(weighttype(1:80),'(80a)') ' '
622              write(weighttype(1:80),'(a)') "wlwdown"
623              call ctrl_set_pack_xy(
624         &         cunit, ivartype, forcingPrecond,
625         &         fname_lwdown(ictrlgrad),
626         &         "maskCtrlC", weighttype, lxxadxx, mythid)
627    #endif
628    
629    #ifdef ALLOW_EVAP_CONTROL
630              ivartype = 37
631              write(weighttype(1:80),'(80a)') ' '
632              write(weighttype(1:80),'(a)') "wevap"
633              call ctrl_set_pack_xy(
634         &         cunit, ivartype, forcingPrecond,
635         &         fname_evap(ictrlgrad),
636         &         "maskCtrlC", weighttype, lxxadxx, mythid)
637    #endif
638    
639    #ifdef ALLOW_SNOWPRECIP_CONTROL
640              ivartype = 38
641              write(weighttype(1:80),'(80a)') ' '
642              write(weighttype(1:80),'(a)') "wsnowprecip"
643              call ctrl_set_pack_xy(
644         &         cunit, ivartype, forcingPrecond,
645         &         fname_snowprecip(ictrlgrad),
646         &         "maskCtrlC", weighttype, lxxadxx, mythid)
647    #endif
648    
649    #ifdef ALLOW_APRESSURE_CONTROL
650              ivartype = 39
651              write(weighttype(1:80),'(80a)') ' '
652              write(weighttype(1:80),'(a)') "wapressure"
653              call ctrl_set_pack_xy(
654         &         cunit, ivartype, forcingPrecond,
655         &         fname_apressure(ictrlgrad),
656         &         "maskCtrlC", weighttype, lxxadxx, mythid)
657    #endif
658    
659    #ifdef ALLOW_RUNOFF_CONTROL
660              ivartype = 40
661              write(weighttype(1:80),'(80a)') ' '
662              write(weighttype(1:80),'(a)') "wrunoff"
663              call ctrl_set_pack_xy(
664         &         cunit, ivartype, forcingPrecond,
665         &         fname_runoff(ictrlgrad),
666         &         "maskCtrlC", weighttype, lxxadxx, mythid)
667    #endif
668    
669    #ifdef ALLOW_SIAREA_CONTROL
670              ivartype = 41
671              write(weighttype(1:80),'(80a)') ' '
672              write(weighttype(1:80),'(a)') "wunit"
673              call ctrl_set_pack_xy(
674         &         cunit, ivartype, forcingPrecond,
675         &         fname_siarea(ictrlgrad),
676         &         "maskCtrlC", weighttype, lxxadxx, mythid)
677    #endif
678    
679    #ifdef ALLOW_SIHEFF_CONTROL
680              ivartype = 42
681              write(weighttype(1:80),'(80a)') ' '
682              write(weighttype(1:80),'(a)') "wunit"
683              call ctrl_set_pack_xy(
684         &         cunit, ivartype, forcingPrecond,
685         &         fname_siheff(ictrlgrad),
686         &         "maskCtrlC", weighttype, lxxadxx, mythid)
687    #endif
688    
689    #ifdef ALLOW_SIHSNOW_CONTROL
690              ivartype = 43
691              write(weighttype(1:80),'(80a)') ' '
692              write(weighttype(1:80),'(a)') "wunit"
693              call ctrl_set_pack_xy(
694         &         cunit, ivartype, forcingPrecond,
695         &         fname_sihsnow(ictrlgrad),
696         &         "maskCtrlC", weighttype, lxxadxx, mythid)
697    #endif
698    
699    #ifdef ALLOW_KAPREDI_CONTROL
700              ivartype = 44
701              write(weighttype(1:80),'(80a)') ' '
702              write(weighttype(1:80),'(a)') "wkapredi"
703              call ctrl_set_pack_xyz(
704         &         cunit, ivartype, fname_kapredi(ictrlgrad), "maskCtrlC",
705         &         weighttype, wkapredi, lxxadxx, mythid)
706    #endif
707    
708    #ifdef ALLOW_SHIFWFLX_CONTROL
709              ivartype = 45
710              write(weighttype(1:80),'(80a)') ' '
711              write(weighttype(1:80),'(a)') "wshifwflx"
712              call ctrl_set_pack_xy(
713         &         cunit, ivartype, forcingPrecond,
714         &         fname_shifwflx(ictrlgrad),
715         &         "maskCtrlI", weighttype, lxxadxx, mythid)
716    #endif
717    
718    #ifdef ALLOW_GENARR2D_CONTROL
719           do iarr = 1, maxCtrlArr2D
720              call ctrl_set_fname( xx_genarr2d_file(iarr),
721         O                         fname_local, mythid )
722              ivartype    = 100+iarr
723    cc          write(weighttype(1:80),'(80a)') ' '
724    cc          write(weighttype(1:80),'(a)') "wunit"
725              call ctrl_set_pack_xy(
726         &         cunit, ivartype, genarr2dPrecond(iarr),
727         &         fname_local(ictrlgrad), "maskCtrlC",
728         &         xx_genarr2d_weight(iarr),
729         &         lxxadxx, mythid)
730           enddo
731    #endif
732    
733    #ifdef ALLOW_GENARR3D_CONTROL
734           do iarr = 1, maxCtrlArr3D
735              call ctrl_set_fname( xx_genarr3d_file(iarr),
736         O                         fname_local, mythid )
737              ivartype    = 200+iarr
738    cc          write(weighttype(1:80),'(80a)') ' '
739    cc          write(weighttype(1:80),'(a)') "wunit"
740              call ctrl_set_pack_xyz(
741         &         cunit, ivartype, fname_local(ictrlgrad), "maskCtrlC",
742         &         xx_genarr3d_weight(iarr),
743         &         wunit, lxxadxx, mythid)
744           enddo
745  #endif  #endif
746    
747            close ( cunit )  #ifdef ALLOW_GENTIM2D_CONTROL
748           do iarr = 1, maxCtrlTim2D
749              call ctrl_set_fname( xx_gentim2d_file(iarr),
750         O                         fname_local, mythid )
751              ivartype    = 300+iarr
752    cc          write(weighttype(1:80),'(80a)') ' '
753    cc          write(weighttype(1:80),'(a)') "wunit"
754              call ctrl_set_pack_xy(
755         &         cunit, ivartype, gentim2dPrecond(iarr),
756         &         fname_local(ictrlgrad), "maskCtrlC",
757         &         xx_gentim2d_weight(iarr),
758         &         lxxadxx, mythid)
759           enddo
760    #endif
761    
762          _END_MASTER( mythid )  #ifdef ALLOW_PACKUNPACK_METHOD2
763          _BEGIN_MASTER( mythid )
764          IF ( myProcId .eq. 0 ) THEN
765    #endif
766    
767           close ( cunit )
768           ENDIF !IF ( myProcId .eq. 0 )
769           _END_MASTER( mythid )
770          _BARRIER
771  #endif /* EXCLUDE_CTRL_PACK */  #endif /* EXCLUDE_CTRL_PACK */
772    
773        return        return
774        end        end
   
Legend:
Removed from v.1.25  
changed lines
  Added in v.1.50
  ViewVC Help
Powered by ViewVC 1.1.22