/[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.15 by mlosch, Fri Dec 3 00:48:57 2004 UTC revision 1.50 by heimbach, Fri Feb 1 19:25:32 2013 UTC
# Line 1  Line 1 
 C  
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 19  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 43  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 "cost.h"  #include "CTRL_SIZE.h"
48    #include "CTRL_GENARR.h"
49  #include "optim.h"  #include "optim.h"
50    
51    #ifdef ALLOW_COST
52    # include "cost.h"
53    #endif
54  #ifdef ALLOW_ECCO  #ifdef ALLOW_ECCO
55  # include "ecco_cost.h"  # include "ecco_cost.h"
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 69  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 111  c--   Assign file names. Line 124  c--   Assign file names.
124        call ctrl_set_fname(xx_tauv_file, fname_tauv, mythid)        call ctrl_set_fname(xx_tauv_file, fname_tauv, mythid)
125        call ctrl_set_fname(xx_atemp_file, fname_atemp, mythid)        call ctrl_set_fname(xx_atemp_file, fname_atemp, mythid)
126        call ctrl_set_fname(xx_aqh_file, fname_aqh, mythid)        call ctrl_set_fname(xx_aqh_file, fname_aqh, mythid)
127          call ctrl_set_fname(xx_precip_file, fname_precip, mythid)
128          call ctrl_set_fname(xx_swflux_file, fname_swflux, mythid)
129          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 119  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)
152          call ctrl_set_fname(xx_edtaux_file, fname_edtaux, mythid)
153          call ctrl_set_fname(xx_edtauy_file, fname_edtauy, mythid)
154          call ctrl_set_fname(xx_uvel_file, fname_uvel, mythid)
155          call ctrl_set_fname(xx_vvel_file, fname_vvel, mythid)
156          call ctrl_set_fname(xx_etan_file, fname_etan, mythid)
157          call ctrl_set_fname(xx_relaxsst_file, fname_relaxsst, mythid)
158          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  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 )
169    
170        if ( first ) then        if ( first ) then
# Line 137  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: unpacking ', 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: unpacking ', 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 175  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 196  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), "hFacC",       &         cunit, ivartype, fname_theta(ictrlgrad), "maskCtrlC",
258       &         weighttype, wtheta, lxxadxx, mythid)       &         weighttype, wtheta, lxxadxx, mythid)
259  #endif  #endif
260    
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), "hFacC",       &         cunit, ivartype, fname_salt(ictrlgrad), "maskCtrlC",
267       &         weighttype, wsalt, lxxadxx, mythid)       &         weighttype, wsalt, lxxadxx, mythid)
268  #endif  #endif
269    
270  #if (defined (ALLOW_HFLUX_CONTROL) || \  #if (defined (ALLOW_HFLUX_CONTROL) || defined (ALLOW_HFLUX0_CONTROL))
      defined (ALLOW_HFLUX0_CONTROL))  
271            ivartype = 3            ivartype = 3
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), "hFacC",       &         cunit, ivartype, forcingPrecond,
276         &         fname_hflux(ictrlgrad), "maskCtrlC",
277       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
278  #endif  #endif
279    
280  #if (defined (ALLOW_SFLUX_CONTROL) || \  #if (defined (ALLOW_SFLUX_CONTROL) || defined (ALLOW_SFLUX0_CONTROL))
      defined (ALLOW_SFLUX0_CONTROL))  
281            ivartype = 4            ivartype = 4
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), "hFacC",       &         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) || \  #if (defined (ALLOW_USTRESS_CONTROL) || defined (ALLOW_TAUU0_CONTROL))
291       defined (ALLOW_TAUU0_CONTROL))  #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), "maskW",  #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) || \  #if (defined (ALLOW_VSTRESS_CONTROL) || defined (ALLOW_TAUV0_CONTROL))
312       defined (ALLOW_TAUV0_CONTROL))  #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), "maskS",  #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 259  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), "hFacC",       &         cunit, ivartype, forcingPrecond,
338         &         fname_atemp(ictrlgrad), "maskCtrlC",
339       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
340  #endif  #endif
341    
# Line 268  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), "hFacC",       &         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), "maskW",       &         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), "maskS",       &         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 331  C     place holder of obsolete variable Line 422  C     place holder of obsolete variable
422            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
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), "hFacC",       &         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 340  C     place holder of obsolete variable Line 431  C     place holder of obsolete variable
431            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
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), "hFacC",       &         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 349  C     place holder of obsolete variable Line 440  C     place holder of obsolete variable
440            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
441            write(weighttype(1:80),'(a)') "wtr1"            write(weighttype(1:80),'(a)') "wtr1"
442            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
443       &         cunit, ivartype, fname_tr1(ictrlgrad), "hFacC",       &         cunit, ivartype, fname_tr1(ictrlgrad), "maskCtrlC",
444       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
445  #endif  #endif
446    
447  #ifdef ALLOW_SST0_CONTROL  #if (defined (ALLOW_SST_CONTROL) || defined (ALLOW_SST0_CONTROL))
448            ivartype = 18            ivartype = 18
449            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
450            write(weighttype(1:80),'(a)') "wsst0"            write(weighttype(1:80),'(a)') "wsst"
451            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
452       &         cunit, ivartype, fname_sst(ictrlgrad), "hFacC",       &         cunit, ivartype, forcingPrecond,
453         &         fname_sst(ictrlgrad), "maskCtrlC",
454       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
455  #endif  #endif
456    
457  #ifdef ALLOW_SSS0_CONTROL  #if (defined (ALLOW_SSS_CONTROL) || defined (ALLOW_SSS0_CONTROL))
458            ivartype = 19            ivartype = 19
459            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
460            write(weighttype(1:80),'(a)') "wsss0"            write(weighttype(1:80),'(a)') "wsss"
461            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
462       &         cunit, ivartype, fname_sss(ictrlgrad), "hFacC",       &         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), "hFacC",  
      &         weighttype, wunit, lxxadxx, mythid)  
 # else  
471            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
472       &         cunit, ivartype, fname_hfacc(ictrlgrad), "hFacC",       &         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
479            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
480            write(weighttype(1:80),'(a)') "wefluxy0"            write(weighttype(1:80),'(a)') "wefluxy0"
481            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
482       &         cunit, ivartype, fname_efluxy(ictrlgrad), "hFacS",       &         cunit, ivartype, fname_efluxy(ictrlgrad), "maskCtrlS",
483       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
484  #endif  #endif
485    
# Line 400  C     place holder of obsolete variable Line 488  C     place holder of obsolete variable
488            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
489            write(weighttype(1:80),'(a)') "wefluxp0"            write(weighttype(1:80),'(a)') "wefluxp0"
490            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
491       &         cunit, ivartype, fname_efluxp(ictrlgrad), "hFacV",       &         cunit, ivartype, fname_efluxp(ictrlgrad), "maskhFacV",
492       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
493  #endif  #endif
494    
# Line 409  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), "hFacC",       &         cunit, ivartype, forcingPrecond,
501         &         fname_bottomdrag(ictrlgrad), "maskCtrlC",
502       &         weighttype, lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
503  #endif  #endif
504    
505            close ( cunit )  #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
514    
515          _END_MASTER( mythid )  #ifdef ALLOW_EDDYPSI_CONTROL
516              ivartype = 25
517              write(weighttype(1:80),'(80a)') ' '
518              write(weighttype(1:80),'(a)') "wedtaux"
519              call ctrl_set_pack_xyz(
520         &         cunit, ivartype, fname_edtaux(ictrlgrad), "maskCtrlW",
521         &         weighttype, wedtaux, lxxadxx, mythid)
522    
523              ivartype = 26
524              write(weighttype(1:80),'(80a)') ' '
525              write(weighttype(1:80),'(a)') "wedtauy"
526              call ctrl_set_pack_xyz(
527         &         cunit, ivartype, fname_edtauy(ictrlgrad), "maskCtrlS",
528         &         weighttype, wedtauy, lxxadxx, mythid)
529    #endif
530    
531    #ifdef ALLOW_UVEL0_CONTROL
532              ivartype = 27
533              write(weighttype(1:80),'(80a)') ' '
534              write(weighttype(1:80),'(a)') "wuvel"
535              call ctrl_set_pack_xyz(
536         &         cunit, ivartype, fname_uvel(ictrlgrad), "maskCtrlW",
537         &         weighttype, wuvel, lxxadxx, mythid)
538    #endif
539    
540    #ifdef ALLOW_VVEL0_CONTROL
541              ivartype = 28
542              write(weighttype(1:80),'(80a)') ' '
543              write(weighttype(1:80),'(a)') "wvvel"
544              call ctrl_set_pack_xyz(
545         &         cunit, ivartype, fname_vvel(ictrlgrad), "maskCtrlS",
546         &         weighttype, wvvel, lxxadxx, mythid)
547    #endif
548    
549    #ifdef ALLOW_ETAN0_CONTROL
550              ivartype = 29
551              write(weighttype(1:80),'(80a)') ' '
552              write(weighttype(1:80),'(a)') "wetan"
553              call ctrl_set_pack_xy(
554         &         cunit, ivartype, forcingPrecond,
555         &         fname_etan(ictrlgrad),
556         &         "maskCtrlC", weighttype, lxxadxx, mythid)
557    #endif
558    
559    #ifdef ALLOW_RELAXSST_CONTROL
560              ivartype = 30
561              write(weighttype(1:80),'(80a)') ' '
562              write(weighttype(1:80),'(a)') "wrelaxsst"
563              call ctrl_set_pack_xy(
564         &         cunit, ivartype, forcingPrecond,
565         &         fname_relaxsst(ictrlgrad),
566         &         "maskCtrlC", weighttype, lxxadxx, mythid)
567    #endif
568    
569    #ifdef ALLOW_RELAXSSS_CONTROL
570              ivartype = 31
571              write(weighttype(1:80),'(80a)') ' '
572              write(weighttype(1:80),'(a)') "wrelaxsss"
573              call ctrl_set_pack_xy(
574         &         cunit, ivartype, forcingPrecond,
575         &         fname_relaxsss(ictrlgrad),
576         &         "maskCtrlC", weighttype, lxxadxx, mythid)
577    #endif
578    
579    #ifdef ALLOW_PRECIP_CONTROL
580              ivartype = 32
581              write(weighttype(1:80),'(80a)') ' '
582              write(weighttype(1:80),'(a)') "wprecip"
583              call ctrl_set_pack_xy(
584         &         cunit, ivartype, forcingPrecond,
585         &         fname_precip(ictrlgrad),
586         &         "maskCtrlC", weighttype, lxxadxx, mythid)
587    #endif
588    
589    #ifdef ALLOW_SWFLUX_CONTROL
590              ivartype = 33
591              write(weighttype(1:80),'(80a)') ' '
592              write(weighttype(1:80),'(a)') "wswflux"
593              call ctrl_set_pack_xy(
594         &         cunit, ivartype, forcingPrecond,
595         &         fname_swflux(ictrlgrad),
596         &         "maskCtrlC", weighttype, lxxadxx, mythid)
597    #endif
598    
599    #ifdef ALLOW_SWDOWN_CONTROL
600              ivartype = 34
601              write(weighttype(1:80),'(80a)') ' '
602              write(weighttype(1:80),'(a)') "wswdown"
603              call ctrl_set_pack_xy(
604         &         cunit, ivartype, forcingPrecond,
605         &         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
746    
747    #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    #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.15  
changed lines
  Added in v.1.50
  ViewVC Help
Powered by ViewVC 1.1.22