/[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.9 by heimbach, Thu Jul 24 22:00:18 2003 UTC revision 1.30 by heimbach, Thu Jun 21 04:06:21 2007 UTC
# Line 1  Line 1 
1    C $Header$
2    C $Name$
3    
4    #include "PACKAGES_CONFIG.h"
5  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
6    
7          subroutine ctrl_pack( first, mythid )
       subroutine ctrl_pack(  
      I                      myiter,  
      I                      mytime,  
      I                      mythid  
      &                    )  
8    
9  c     ==================================================================  c     ==================================================================
10  c     SUBROUTINE ctrl_pack  c     SUBROUTINE ctrl_pack
# Line 28  c Line 26  c
26  c              G. Gebbie, added open boundary control packing,  c              G. Gebbie, added open boundary control packing,
27  c                  gebbie@mit.edu  18 -Mar- 2003  c                  gebbie@mit.edu  18 -Mar- 2003
28  c  c
29    c              heimbach@mit.edu totally restructured 28-Oct-2003
30    c
31  c     ==================================================================  c     ==================================================================
32  c     SUBROUTINE ctrl_pack  c     SUBROUTINE ctrl_pack
33  c     ==================================================================  c     ==================================================================
# Line 41  c     == global variables == Line 41  c     == global variables ==
41  #include "PARAMS.h"  #include "PARAMS.h"
42  #include "GRID.h"  #include "GRID.h"
43    
 #include "ecco.h"  
44  #include "ctrl.h"  #include "ctrl.h"
 #include "cost.h"  
   
 #ifdef ALLOW_ECCO_OPTIMIZATION  
45  #include "optim.h"  #include "optim.h"
46    
47    #ifdef ALLOW_COST
48    # include "cost.h"
49    #endif
50    #ifdef ALLOW_ECCO
51    # include "ecco_cost.h"
52    #else
53    # include "ctrl_weights.h"
54  #endif  #endif
55    
56  c     == routine arguments ==  c     == routine arguments ==
57    
58        integer myiter        logical first
       _RL     mytime  
59        integer mythid        integer mythid
60    
61    #ifndef EXCLUDE_CTRL_PACK
62  c     == local variables ==  c     == local variables ==
63    
64  #ifndef ALLOW_ECCO_OPTIMIZATION        _RL    fcloc
       integer optimcycle  
 #endif  
65    
66        integer i, j, k        integer i, j, k
67        integer ii        integer ii
# Line 72  c     == local variables == Line 74  c     == local variables ==
74        logical doglobalread        logical doglobalread
75        logical ladinit        logical ladinit
76        integer cbuffindex        integer cbuffindex
77          logical lxxadxx
78          
79        integer cunit        integer cunit
80        _RL     tmpvar        integer ictrlgrad
81    
82        character*(128) cfile        character*(128) cfile
83        character*( 80) weighttype        character*( 80) weighttype
84    
       character*( 80) fname_theta  
       character*( 80) fname_salt  
       character*( 80) fname_hflux  
       character*( 80) fname_sflux  
       character*( 80) fname_tauu  
       character*( 80) fname_tauv  
       character*( 80) adfname_theta  
       character*( 80) adfname_salt  
       character*( 80) adfname_hflux  
       character*( 80) adfname_sflux  
       character*( 80) adfname_tauu  
       character*( 80) adfname_tauv  
       character*( 80)   fname_atemp  
       character*( 80) adfname_atemp  
       character*( 80)   fname_aqh  
       character*( 80) adfname_aqh  
       character*( 80)   fname_uwind  
       character*( 80) adfname_uwind  
       character*( 80)   fname_vwind  
       character*( 80) adfname_vwind  
       character*( 80)   fname_obcsn  
       character*( 80) adfname_obcsn  
       character*( 80)   fname_obcss  
       character*( 80) adfname_obcss  
       character*( 80)   fname_obcsw  
       character*( 80) adfname_obcsw  
       character*( 80)   fname_obcse  
       character*( 80) adfname_obcse  
       character*( 80)   fname_diffkr  
       character*( 80) adfname_diffkr  
       character*( 80)   fname_kapgm  
       character*( 80) adfname_kapgm  
       character*( 80)   fname_tr1  
       character*( 80) adfname_tr1  
       character*( 80)   fname_sst  
       character*( 80) adfname_sst  
       character*( 80)   fname_sss  
       character*( 80) adfname_sss  
       character*( 80)   fname_hfacc  
       character*( 80) adfname_hfacc  
       character*( 80)   fname_efluxy  
       character*( 80) adfname_efluxy  
       character*( 80)   fname_efluxp  
       character*( 80) adfname_efluxp  
       character*( 80)   fname_bottomdrag  
       character*( 80) adfname_bottomdrag  
   
       logical lxxadxx  
   
85  c     == external ==  c     == external ==
86    
87        integer  ilnblnk        integer  ilnblnk
# Line 136  c     == external == Line 90  c     == external ==
90  c     == end of interface ==  c     == end of interface ==
91    
92  #ifndef ALLOW_ECCO_OPTIMIZATION  #ifndef ALLOW_ECCO_OPTIMIZATION
93        optimcycle = 0        fmin       = 0. _d 0
94  #endif  #endif
95    
       tmpvar = -9999. _d 0  
   
96  c--   Tiled files are used.  c--   Tiled files are used.
97        doglobalread = .false.        doglobalread = .false.
98    
99  c--   Initialise adjoint variables on active files.  c--   Initialise adjoint variables on active files.
100        ladinit = .false.        ladinit = .false.
101    
102    c--   Initialise global buffer index
103          nbuffglobal = 0
104    
105  c--   Assign file names.  c--   Assign file names.
106    
107        call ctrl_set_fname(        call ctrl_set_fname(xx_theta_file, fname_theta, mythid)
108       I     xx_theta_file, fname_theta, adfname_theta, mythid )        call ctrl_set_fname(xx_salt_file, fname_salt, mythid)
109        call ctrl_set_fname(        call ctrl_set_fname(xx_hflux_file, fname_hflux, mythid)
110       I     xx_salt_file, fname_salt, adfname_salt, mythid )        call ctrl_set_fname(xx_sflux_file, fname_sflux, mythid)
111        call ctrl_set_fname(        call ctrl_set_fname(xx_tauu_file, fname_tauu, mythid)
112       I     xx_hflux_file, fname_hflux, adfname_hflux, mythid )        call ctrl_set_fname(xx_tauv_file, fname_tauv, mythid)
113        call ctrl_set_fname(        call ctrl_set_fname(xx_atemp_file, fname_atemp, mythid)
114       I     xx_sflux_file, fname_sflux, adfname_sflux, mythid )        call ctrl_set_fname(xx_aqh_file, fname_aqh, mythid)
115        call ctrl_set_fname(        call ctrl_set_fname(xx_precip_file, fname_precip, mythid)
116       I     xx_tauu_file, fname_tauu, adfname_tauu, mythid )        call ctrl_set_fname(xx_swflux_file, fname_swflux, mythid)
117        call ctrl_set_fname(        call ctrl_set_fname(xx_swdown_file, fname_swdown, mythid)
118       I     xx_tauv_file, fname_tauv, adfname_tauv, mythid )        call ctrl_set_fname(xx_lwflux_file, fname_lwflux, mythid)
119        call ctrl_set_fname(        call ctrl_set_fname(xx_lwdown_file, fname_lwdown, mythid)
120       I     xx_atemp_file, fname_atemp, adfname_atemp, mythid )        call ctrl_set_fname(xx_evap_file, fname_evap, mythid)
121        call ctrl_set_fname(        call ctrl_set_fname(xx_snowprecip_file, fname_snowprecip, mythid)
122       I     xx_aqh_file, fname_aqh, adfname_aqh, mythid )        call ctrl_set_fname(xx_apressure_file, fname_apressure, mythid)
123        call ctrl_set_fname(        call ctrl_set_fname(xx_runoff_file, fname_runoff, mythid)
124       I     xx_uwind_file, fname_uwind, adfname_uwind, mythid )  
125        call ctrl_set_fname(        call ctrl_set_fname(xx_uwind_file, fname_uwind, mythid)
126       I     xx_vwind_file, fname_vwind, adfname_vwind, mythid )        call ctrl_set_fname(xx_vwind_file, fname_vwind, mythid)
127        call ctrl_set_fname(        call ctrl_set_fname(xx_obcsn_file, fname_obcsn, mythid)
128       I     xx_obcsn_file, fname_obcsn, adfname_obcsn, mythid )        call ctrl_set_fname(xx_obcss_file, fname_obcss, mythid)
129        call ctrl_set_fname(        call ctrl_set_fname(xx_obcsw_file, fname_obcsw, mythid)
130       I     xx_obcss_file, fname_obcss, adfname_obcss, mythid )        call ctrl_set_fname(xx_obcse_file, fname_obcse, mythid)
131        call ctrl_set_fname(        call ctrl_set_fname(xx_diffkr_file, fname_diffkr, mythid)
132       I     xx_obcsw_file, fname_obcsw, adfname_obcsw, mythid )        call ctrl_set_fname(xx_kapgm_file, fname_kapgm, mythid)
133        call ctrl_set_fname(        call ctrl_set_fname(xx_tr1_file, fname_tr1, mythid)
134       I     xx_obcse_file, fname_obcse, adfname_obcse, mythid )        call ctrl_set_fname(xx_sst_file, fname_sst, mythid)
135        call ctrl_set_fname(        call ctrl_set_fname(xx_sss_file, fname_sss, mythid)
136       I     xx_diffkr_file, fname_diffkr, adfname_diffkr, mythid )        call ctrl_set_fname(xx_depth_file, fname_depth, mythid)
137        call ctrl_set_fname(        call ctrl_set_fname(xx_efluxy_file, fname_efluxy, mythid)
138       I     xx_kapgm_file, fname_kapgm, adfname_kapgm, mythid )        call ctrl_set_fname(xx_efluxp_file, fname_efluxp, mythid)
139        call ctrl_set_fname(        call ctrl_set_fname(xx_bottomdrag_file, fname_bottomdrag, mythid)
140       I     xx_tr1_file, fname_tr1, adfname_tr1, mythid )        call ctrl_set_fname(xx_edtaux_file, fname_edtaux, mythid)
141        call ctrl_set_fname(        call ctrl_set_fname(xx_edtauy_file, fname_edtauy, mythid)
142       I     xx_sst_file, fname_sst, adfname_sst, mythid )        call ctrl_set_fname(xx_uvel_file, fname_uvel, mythid)
143        call ctrl_set_fname(        call ctrl_set_fname(xx_vvel_file, fname_vvel, mythid)
144       I     xx_sss_file, fname_sss, adfname_sss, mythid )        call ctrl_set_fname(xx_etan_file, fname_etan, mythid)
145        call ctrl_set_fname(        call ctrl_set_fname(xx_relaxsst_file, fname_relaxsst, mythid)
146       I     xx_hfacc_file, fname_hfacc, adfname_hfacc, mythid )        call ctrl_set_fname(xx_relaxsss_file, fname_relaxsss, mythid)
147        call ctrl_set_fname(        call ctrl_set_fname(xx_siarea_file, fname_siarea, mythid)
148       I     xx_efluxy_file, fname_efluxy, adfname_efluxy, mythid )        call ctrl_set_fname(xx_siheff_file, fname_siheff, mythid)
149        call ctrl_set_fname(        call ctrl_set_fname(xx_sihsnow_file, fname_sihsnow, mythid)
      I     xx_efluxp_file, fname_efluxp, adfname_efluxp, mythid )  
       call ctrl_set_fname(  
      I     xx_bottomdrag_file, fname_bottomdrag, adfname_bottomdrag  
      I   , mythid )  
150    
151  c  c--   Only the master thread will do I/O.
 c--     Only the master thread will do I/O.  
152        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
153    
154  c     >>> Write control vector <<<        if ( first ) then
155    c     >>> Initialise control vector for optimcycle=0 <<<
156  cph   this part was removed since it's not necessary            lxxadxx   = .TRUE.
157  cph   and causes huge amounts of wall clock time on parallel machines            ictrlgrad = 1
158              fcloc     = fmin
159              write(cfile(1:128),'(4a,i4.4)')
160         &         ctrlname(1:9),'_',yctrlid(1:10),
161         &         yctrlpospack, optimcycle
162              print *, 'ph-pack: packing ', ctrlname(1:9)
163          else
164  c     >>> Write gradient vector <<<  c     >>> Write gradient vector <<<
165        lxxadxx = .FALSE.            lxxadxx   = .FALSE.
166              ictrlgrad = 2
167            call mdsfindunit( cunit, mythid )            fcloc     = fc
168            write(cfile(1:128),'(4a,i4.4)')            write(cfile(1:128),'(4a,i4.4)')
169       &    costname(1:9),'_',yctrlid(1:10),'.opt',       &         costname(1:9),'_',yctrlid(1:10),
170       &    optimcycle       &         yctrlpospack, optimcycle
171              print *, 'ph-pack: packing ', costname(1:9)
172            open( cunit, file   = cfile,         endif
173       &               status = 'unknown',  
174       &               form   = 'unformatted',         call mdsfindunit( cunit, mythid )
175       &               access  = 'sequential'   )         open( cunit, file   = cfile,
176         &      status = 'unknown',
177         &      form   = 'unformatted',
178         &      access  = 'sequential'   )
179    
180  c--       Header information.  c--       Header information.
181            write(cunit) nvartype            write(cunit) nvartype
# Line 227  c--       Header information. Line 183  c--       Header information.
183            write(cunit) yctrlid            write(cunit) yctrlid
184            write(cunit) optimCycle            write(cunit) optimCycle
185            write(cunit) fc            write(cunit) fc
186    C     place holder of obsolete variable iG
187            write(cunit) 1            write(cunit) 1
188    C     place holder of obsolete variable jG
189            write(cunit) 1            write(cunit) 1
190            write(cunit) 1            write(cunit) nsx
191            write(cunit) 1            write(cunit) nsy
192            write(cunit) (nWetcGlobal(k), k=1,nr)            write(cunit) (nWetcGlobal(k), k=1,nr)
193            write(cunit) (nWetsGlobal(k), k=1,nr)            write(cunit) (nWetsGlobal(k), k=1,nr)
194            write(cunit) (nWetwGlobal(k), k=1,nr)            write(cunit) (nWetwGlobal(k), k=1,nr)
195  #ifdef ALLOW_CTRL_WETV  #ifdef ALLOW_CTRL_WETV
196            write(cunit) (nWetvGlobal(k), k=1,nr)            write(cunit) (nWetvGlobal(k), k=1,nr)
197  #endif  #endif
198    
199  #ifdef ALLOW_OBCSN_CONTROL  #ifdef ALLOW_OBCSN_CONTROL
200            write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)            write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
201  #endif  #endif
# Line 251  c--       Header information. Line 210  c--       Header information.
210  #endif  #endif
211            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
212            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
213            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (ncvarxmax(i),  i=1,maxcvars)
214            write(cunit) (ny,  i=1,maxcvars)            write(cunit) (ncvarymax(i),  i=1,maxcvars)
215            write(cunit) (ncvarnrmax(i), i=1,maxcvars)            write(cunit) (ncvarnrmax(i), i=1,maxcvars)
216            write(cunit) (ncvargrd(i),   i=1,maxcvars)            write(cunit) (ncvargrd(i),   i=1,maxcvars)
217            write(cunit)            write(cunit)
# Line 260  c--       Header information. Line 219  c--       Header information.
219  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
220            ivartype = 1            ivartype = 1
221            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
222            write(weighttype(1:80),'(a)') "wtheta"            write(weighttype(1:80),'(a)') "wthetaLev"
223            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
224       &         cunit, ivartype, adfname_theta, "hFacC",       &         cunit, ivartype, fname_theta(ictrlgrad), "maskCtrlC",
225       &         weighttype, wtheta, lxxadxx, mythid)       &         weighttype, wtheta, lxxadxx, mythid)
226  #endif  #endif
227    
228  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
229            ivartype = 2            ivartype = 2
230            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
231            write(weighttype(1:80),'(a)') "wsalt"            write(weighttype(1:80),'(a)') "wsaltLev"
232            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
233       &         cunit, ivartype, adfname_salt, "hFacC",       &         cunit, ivartype, fname_salt(ictrlgrad), "maskCtrlC",
234       &         weighttype, wsalt, lxxadxx, mythid)       &         weighttype, wsalt, lxxadxx, mythid)
235  #endif  #endif
236    
237  #if (defined (ALLOW_HFLUX_CONTROL) || \  #if (defined (ALLOW_HFLUX_CONTROL) || defined (ALLOW_HFLUX0_CONTROL))
      defined (ALLOW_HFLUX0_CONTROL))  
238            ivartype = 3            ivartype = 3
239            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
240            write(weighttype(1:80),'(a)') "whflux"            write(weighttype(1:80),'(a)') "whflux"
241            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
242       &         cunit, ivartype, adfname_hflux, "hFacC", weighttype,       &         cunit, ivartype, fname_hflux(ictrlgrad), "maskCtrlC",
243       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
244  #endif  #endif
245    
246  #if (defined (ALLOW_SFLUX_CONTROL) || \  #if (defined (ALLOW_SFLUX_CONTROL) || defined (ALLOW_SFLUX0_CONTROL))
      defined (ALLOW_SFLUX0_CONTROL))  
247            ivartype = 4            ivartype = 4
248            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
249            write(weighttype(1:80),'(a)') "wsflux"            write(weighttype(1:80),'(a)') "wsflux"
250            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
251       &         cunit, ivartype, adfname_sflux, "hFacC", weighttype,       &         cunit, ivartype, fname_sflux(ictrlgrad), "maskCtrlC",
252       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
253  #endif  #endif
254    
255  #if (defined (ALLOW_USTRESS_CONTROL) || \  #if (defined (ALLOW_USTRESS_CONTROL) || defined (ALLOW_TAUU0_CONTROL))
      defined (ALLOW_TAUU0_CONTROL))  
256            ivartype = 5            ivartype = 5
257            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
258            write(weighttype(1:80),'(a)') "wtauu"            write(weighttype(1:80),'(a)') "wtauu"
259            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
260       &         cunit, ivartype, adfname_tauu, "maskW", weighttype,       &         cunit, ivartype, fname_tauu(ictrlgrad), "maskCtrlW",
261       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
262  #endif  #endif
263    
264  #if (defined (ALLOW_VSTRESS_CONTROL) || \  #if (defined (ALLOW_VSTRESS_CONTROL) || defined (ALLOW_TAUV0_CONTROL))
      defined (ALLOW_TAUV0_CONTROL))  
265            ivartype = 6            ivartype = 6
266            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
267            write(weighttype(1:80),'(a)') "wtauv"            write(weighttype(1:80),'(a)') "wtauv"
268            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
269       &         cunit, ivartype, adfname_tauv, "maskS", weighttype,       &         cunit, ivartype, fname_tauv(ictrlgrad), "maskCtrlS",
270       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
271  #endif  #endif
272    
273  #ifdef ALLOW_ATEMP_CONTROL  #ifdef ALLOW_ATEMP_CONTROL
# Line 320  c--       Header information. Line 275  c--       Header information.
275            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
276            write(weighttype(1:80),'(a)') "watemp"            write(weighttype(1:80),'(a)') "watemp"
277            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
278       &         cunit, ivartype, adfname_atemp, "hFacC", weighttype,       &         cunit, ivartype, fname_atemp(ictrlgrad), "maskCtrlC",
279       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
280  #endif  #endif
281    
282  #ifdef ALLOW_AQH_CONTROL  #ifdef ALLOW_AQH_CONTROL
# Line 329  c--       Header information. Line 284  c--       Header information.
284            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
285            write(weighttype(1:80),'(a)') "waqh"            write(weighttype(1:80),'(a)') "waqh"
286            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
287       &         cunit, ivartype, adfname_aqh, "hFacC", weighttype,       &         cunit, ivartype, fname_aqh(ictrlgrad), "maskCtrlC",
288       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
289  #endif  #endif
290    
291  #ifdef ALLOW_UWIND_CONTROL  #ifdef ALLOW_UWIND_CONTROL
# Line 338  c--       Header information. Line 293  c--       Header information.
293            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
294            write(weighttype(1:80),'(a)') "wuwind"            write(weighttype(1:80),'(a)') "wuwind"
295            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
296       &         cunit, ivartype, adfname_uwind, "maskW", weighttype,       &         cunit, ivartype, fname_uwind(ictrlgrad), "maskCtrlC",
297       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
298  #endif  #endif
299    
300  #ifdef ALLOW_VWIND_CONTROL  #ifdef ALLOW_VWIND_CONTROL
# Line 347  c--       Header information. Line 302  c--       Header information.
302            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
303            write(weighttype(1:80),'(a)') "wvwind"            write(weighttype(1:80),'(a)') "wvwind"
304            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
305       &         cunit, ivartype, adfname_vwind, "maskS", weighttype,       &         cunit, ivartype, fname_vwind(ictrlgrad), "maskCtrlC",
306       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
307  #endif  #endif
308    
309  #ifdef ALLOW_OBCSN_CONTROL  #ifdef ALLOW_OBCSN_CONTROL
# Line 356  c--       Header information. Line 311  c--       Header information.
311            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
312            write(weighttype(1:80),'(a)') "wobcsn"            write(weighttype(1:80),'(a)') "wobcsn"
313            call ctrl_set_pack_xz(            call ctrl_set_pack_xz(
314       &         cunit, ivartype, adfname_obcsn, "maskobcsn",       &         cunit, ivartype, fname_obcsn(ictrlgrad), "maskobcsn",
315       &         weighttype, wobcsn, lxxadxx, mythid)       &         weighttype, wobcsn, lxxadxx, mythid)
316  #endif  #endif
317    
# Line 365  c--       Header information. Line 320  c--       Header information.
320            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
321            write(weighttype(1:80),'(a)') "wobcss"            write(weighttype(1:80),'(a)') "wobcss"
322            call ctrl_set_pack_xz(            call ctrl_set_pack_xz(
323       &         cunit, ivartype, adfname_obcss, "maskobcss",       &         cunit, ivartype, fname_obcss(ictrlgrad), "maskobcss",
324       &         weighttype, wobcss, lxxadxx, mythid)       &         weighttype, wobcss, lxxadxx, mythid)
325  #endif  #endif
326    
# Line 374  c--       Header information. Line 329  c--       Header information.
329            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
330            write(weighttype(1:80),'(a)') "wobcsw"            write(weighttype(1:80),'(a)') "wobcsw"
331            call ctrl_set_pack_yz(            call ctrl_set_pack_yz(
332       &         cunit, ivartype, adfname_obcsw, "maskobcsw",       &         cunit, ivartype, fname_obcsw(ictrlgrad), "maskobcsw",
333       &         weighttype, wobcsw, lxxadxx, mythid)       &         weighttype, wobcsw, lxxadxx, mythid)
334  #endif  #endif
335    
# Line 383  c--       Header information. Line 338  c--       Header information.
338            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
339            write(weighttype(1:80),'(a)') "wobcse"            write(weighttype(1:80),'(a)') "wobcse"
340            call ctrl_set_pack_yz(            call ctrl_set_pack_yz(
341       &         cunit, ivartype, adfname_obcse, "maskobcse",       &         cunit, ivartype, fname_obcse(ictrlgrad), "maskobcse",
342       &         weighttype, wobcse, lxxadxx, mythid)       &         weighttype, wobcse, lxxadxx, mythid)
343  #endif  #endif
344    
# Line 392  c--       Header information. Line 347  c--       Header information.
347            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
348            write(weighttype(1:80),'(a)') "wdiffkr"            write(weighttype(1:80),'(a)') "wdiffkr"
349            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
350       &         cunit, ivartype, adfname_diffkr, "hFacC",       &         cunit, ivartype, fname_diffkr(ictrlgrad), "maskCtrlC",
351       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wdiffkr, lxxadxx, mythid)
352  #endif  #endif
353    
354  #ifdef ALLOW_KAPGM_CONTROL  #ifdef ALLOW_KAPGM_CONTROL
# Line 401  c--       Header information. Line 356  c--       Header information.
356            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
357            write(weighttype(1:80),'(a)') "wkapgm"            write(weighttype(1:80),'(a)') "wkapgm"
358            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
359       &         cunit, ivartype, adfname_kapgm, "hFacC",       &         cunit, ivartype, fname_kapgm(ictrlgrad), "maskCtrlC",
360       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wkapgm, lxxadxx, mythid)
361  #endif  #endif
362    
363  #ifdef ALLOW_TR10_CONTROL  #ifdef ALLOW_TR10_CONTROL
# Line 410  c--       Header information. Line 365  c--       Header information.
365            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
366            write(weighttype(1:80),'(a)') "wtr1"            write(weighttype(1:80),'(a)') "wtr1"
367            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
368       &         cunit, ivartype, adfname_tr1, "hFacC",       &         cunit, ivartype, fname_tr1(ictrlgrad), "maskCtrlC",
369       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
370  #endif  #endif
371    
372  #ifdef ALLOW_SST0_CONTROL  #if (defined (ALLOW_SST_CONTROL) || defined (ALLOW_SST0_CONTROL))
373            ivartype = 18            ivartype = 18
374            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
375            write(weighttype(1:80),'(a)') "wsst0"            write(weighttype(1:80),'(a)') "wsst"
376            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
377       &         cunit, ivartype, adfname_sst, "hFacC", weighttype,       &         cunit, ivartype, fname_sst(ictrlgrad), "maskCtrlC",
378       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
379  #endif  #endif
380    
381  #ifdef ALLOW_SSS0_CONTROL  #if (defined (ALLOW_SSS_CONTROL) || defined (ALLOW_SSS0_CONTROL))
382            ivartype = 19            ivartype = 19
383            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
384            write(weighttype(1:80),'(a)') "wsss0"            write(weighttype(1:80),'(a)') "wsss"
385            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
386       &         cunit, ivartype, adfname_sss, "hFacC", weighttype,       &         cunit, ivartype, fname_sss(ictrlgrad),
387       &         lxxadxx, mythid)       &         "maskCtrlC", weighttype, lxxadxx, mythid)
388  #endif  #endif
389    
390  #ifdef ALLOW_HFACC_CONTROL  #ifdef ALLOW_DEPTH_CONTROL
391            ivartype = 20            ivartype = 20
392            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
393            write(weighttype(1:80),'(a)') "whfacc"            write(weighttype(1:80),'(a)') "wdepth"
 # ifdef ALLOW_HFACC3D_CONTROL  
           call ctrl_set_pack_xyz(  
      &         cunit, ivartype, adfname_hfacc, "hFacC",  
      &         weighttype, wunit, lxxadxx, mythid)  
 # else  
394            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
395       &         cunit, ivartype, adfname_hfacc, "hFacC", weighttype,       &         cunit, ivartype, fname_depth(ictrlgrad),
396       &         lxxadxx, mythid)       &         "maskCtrlC", weighttype, lxxadxx, mythid)
397  # endif  #endif /* ALLOW_DEPTH_CONTROL */
 #endif  
398    
399  #ifdef ALLOW_EFLUXY0_CONTROL  #ifdef ALLOW_EFLUXY0_CONTROL
400            ivartype = 21            ivartype = 21
401            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
402            write(weighttype(1:80),'(a)') "wefluxy0"            write(weighttype(1:80),'(a)') "wefluxy0"
403            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
404       &         cunit, ivartype, adfname_efluxy, "hFacS",       &         cunit, ivartype, fname_efluxy(ictrlgrad), "maskCtrlS",
405       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
406  #endif  #endif
407    
# Line 461  c--       Header information. Line 410  c--       Header information.
410            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
411            write(weighttype(1:80),'(a)') "wefluxp0"            write(weighttype(1:80),'(a)') "wefluxp0"
412            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
413       &         cunit, ivartype, adfname_efluxp, "hFacV",       &         cunit, ivartype, fname_efluxp(ictrlgrad), "maskhFacV",
414       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
415  #endif  #endif
416    
# Line 470  c--       Header information. Line 419  c--       Header information.
419            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
420            write(weighttype(1:80),'(a)') "wbottomdrag"            write(weighttype(1:80),'(a)') "wbottomdrag"
421            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
422       &         cunit, ivartype, adfname_bottomdrag, "hFacC", weighttype,       &      cunit, ivartype, fname_bottomdrag(ictrlgrad), "maskCtrlC",
423       &         lxxadxx, mythid)       &      weighttype, lxxadxx, mythid)
424    #endif
425    
426    #ifdef ALLOW_EDTAUX_CONTROL
427              ivartype = 25
428              write(weighttype(1:80),'(80a)') ' '
429              write(weighttype(1:80),'(a)') "wedtaux"
430              call ctrl_set_pack_xyz(
431         &         cunit, ivartype, fname_edtaux(ictrlgrad), "maskCtrlW",
432         &         weighttype, wedtaux, lxxadxx, mythid)
433    #endif
434    
435    #ifdef ALLOW_EDTAUY_CONTROL
436              ivartype = 26
437              write(weighttype(1:80),'(80a)') ' '
438              write(weighttype(1:80),'(a)') "wedtauy"
439              call ctrl_set_pack_xyz(
440         &         cunit, ivartype, fname_edtauy(ictrlgrad), "maskCtrlS",
441         &         weighttype, wedtauy, lxxadxx, mythid)
442    #endif
443    
444    #ifdef ALLOW_UVEL0_CONTROL
445              ivartype = 27
446              write(weighttype(1:80),'(80a)') ' '
447              write(weighttype(1:80),'(a)') "wuvel"
448              call ctrl_set_pack_xyz(
449         &         cunit, ivartype, fname_uvel(ictrlgrad), "maskCtrlW",
450         &         weighttype, wunit, lxxadxx, mythid)
451    #endif
452    
453    #ifdef ALLOW_VVEL0_CONTROL
454              ivartype = 28
455              write(weighttype(1:80),'(80a)') ' '
456              write(weighttype(1:80),'(a)') "wvvel"
457              call ctrl_set_pack_xyz(
458         &         cunit, ivartype, fname_vvel(ictrlgrad), "maskCtrlS",
459         &         weighttype, wunit, lxxadxx, mythid)
460    #endif
461    
462    #ifdef ALLOW_ETAN0_CONTROL
463              ivartype = 29
464              write(weighttype(1:80),'(80a)') ' '
465              write(weighttype(1:80),'(a)') "wetan"
466              call ctrl_set_pack_xy(
467         &         cunit, ivartype, fname_etan(ictrlgrad),
468         &         "maskCtrlC", weighttype, lxxadxx, mythid)
469    #endif
470    
471    #ifdef ALLOW_RELAXSST_CONTROL
472              ivartype = 30
473              write(weighttype(1:80),'(80a)') ' '
474              write(weighttype(1:80),'(a)') "wrelaxsst"
475              call ctrl_set_pack_xy(
476         &         cunit, ivartype, fname_relaxsst(ictrlgrad),
477         &         "maskCtrlC", weighttype, lxxadxx, mythid)
478    #endif
479    
480    #ifdef ALLOW_RELAXSSS_CONTROL
481              ivartype = 31
482              write(weighttype(1:80),'(80a)') ' '
483              write(weighttype(1:80),'(a)') "wrelaxsss"
484              call ctrl_set_pack_xy(
485         &         cunit, ivartype, fname_relaxsss(ictrlgrad),
486         &         "maskCtrlC", weighttype, lxxadxx, mythid)
487    #endif
488    
489    #ifdef ALLOW_PRECIP_CONTROL
490              ivartype = 32
491              write(weighttype(1:80),'(80a)') ' '
492              write(weighttype(1:80),'(a)') "wprecip"
493              call ctrl_set_pack_xy(
494         &         cunit, ivartype, fname_precip(ictrlgrad),
495         &         "maskCtrlC", weighttype, lxxadxx, mythid)
496    #endif
497    
498    #ifdef ALLOW_SWFLUX_CONTROL
499              ivartype = 33
500              write(weighttype(1:80),'(80a)') ' '
501              write(weighttype(1:80),'(a)') "wswflux"
502              call ctrl_set_pack_xy(
503         &         cunit, ivartype, fname_swflux(ictrlgrad),
504         &         "maskCtrlC", weighttype, lxxadxx, mythid)
505    #endif
506    
507    #ifdef ALLOW_SWDOWN_CONTROL
508              ivartype = 34
509              write(weighttype(1:80),'(80a)') ' '
510              write(weighttype(1:80),'(a)') "wswdown"
511              call ctrl_set_pack_xy(
512         &         cunit, ivartype, fname_swdown(ictrlgrad),
513         &         "maskCtrlC", weighttype, lxxadxx, mythid)
514    #endif
515    
516    #ifdef ALLOW_LWFLUX_CONTROL
517              ivartype = 35
518              write(weighttype(1:80),'(80a)') ' '
519              write(weighttype(1:80),'(a)') "wlwflux"
520              call ctrl_set_pack_xy(
521         &         cunit, ivartype, fname_lwflux(ictrlgrad),
522         &         "maskCtrlC", weighttype, lxxadxx, mythid)
523    #endif
524    
525    #ifdef ALLOW_LWDOWN_CONTROL
526              ivartype = 36
527              write(weighttype(1:80),'(80a)') ' '
528              write(weighttype(1:80),'(a)') "wlwdown"
529              call ctrl_set_pack_xy(
530         &         cunit, ivartype, fname_lwdown(ictrlgrad),
531         &         "maskCtrlC", weighttype, lxxadxx, mythid)
532    #endif
533    
534    #ifdef ALLOW_EVAP_CONTROL
535              ivartype = 37
536              write(weighttype(1:80),'(80a)') ' '
537              write(weighttype(1:80),'(a)') "wevap"
538              call ctrl_set_pack_xy(
539         &         cunit, ivartype, fname_evap(ictrlgrad),
540         &         "maskCtrlC", weighttype, lxxadxx, mythid)
541    #endif
542    
543    #ifdef ALLOW_SNOWPRECIP_CONTROL
544              ivartype = 38
545              write(weighttype(1:80),'(80a)') ' '
546              write(weighttype(1:80),'(a)') "wsnowprecip"
547              call ctrl_set_pack_xy(
548         &         cunit, ivartype, fname_snowprecip(ictrlgrad),
549         &         "maskCtrlC", weighttype, lxxadxx, mythid)
550    #endif
551    
552    #ifdef ALLOW_APRESSURE_CONTROL
553              ivartype = 39
554              write(weighttype(1:80),'(80a)') ' '
555              write(weighttype(1:80),'(a)') "wapressure"
556              call ctrl_set_pack_xy(
557         &         cunit, ivartype, fname_apressure(ictrlgrad),
558         &         "maskCtrlC", weighttype, lxxadxx, mythid)
559    #endif
560    
561    #ifdef ALLOW_RUNOFF_CONTROL
562              ivartype = 40
563              write(weighttype(1:80),'(80a)') ' '
564              write(weighttype(1:80),'(a)') "wrunoff"
565              call ctrl_set_pack_xy(
566         &         cunit, ivartype, fname_runoff(ictrlgrad),
567         &         "maskCtrlC", weighttype, lxxadxx, mythid)
568    #endif
569    
570    #ifdef ALLOW_SIAREA_CONTROL
571              ivartype = 41
572              write(weighttype(1:80),'(80a)') ' '
573              write(weighttype(1:80),'(a)') "wunit"
574              call ctrl_set_pack_xy(
575         &         cunit, ivartype, fname_siarea(ictrlgrad),
576         &         "maskCtrlC", weighttype, lxxadxx, mythid)
577    #endif
578    
579    #ifdef ALLOW_SIHEFF_CONTROL
580              ivartype = 42
581              write(weighttype(1:80),'(80a)') ' '
582              write(weighttype(1:80),'(a)') "wunit"
583              call ctrl_set_pack_xy(
584         &         cunit, ivartype, fname_siheff(ictrlgrad),
585         &         "maskCtrlC", weighttype, lxxadxx, mythid)
586    #endif
587    
588    #ifdef ALLOW_SIHSNOW_CONTROL
589              ivartype = 43
590              write(weighttype(1:80),'(80a)') ' '
591              write(weighttype(1:80),'(a)') "wunit"
592              call ctrl_set_pack_xy(
593         &         cunit, ivartype, fname_sihsnow(ictrlgrad),
594         &         "maskCtrlC", weighttype, lxxadxx, mythid)
595  #endif  #endif
596    
597            close ( cunit )            close ( cunit )
598    
599          _END_MASTER( mythid )          _END_MASTER( mythid )
600    
601    #endif /* EXCLUDE_CTRL_PACK */
602    
603        return        return
604        end        end
605    
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.30
  ViewVC Help
Powered by ViewVC 1.1.22