/[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.10 by edhill, Thu Oct 23 04:41:40 2003 UTC revision 1.31 by dfer, Tue Jan 15 19:56:27 2008 UTC
# Line 1  Line 1 
 C  
1  C $Header$  C $Header$
2  C $Name$  C $Name$
3    
4  #include "AD_CONFIG.h"  #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 32  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 45  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 76  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 140  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)
150       I     xx_efluxp_file, fname_efluxp, adfname_efluxp, mythid )  cHFLUXM_CONTROL
151        call ctrl_set_fname(        call ctrl_set_fname(xx_hfluxm_file, fname_hfluxm, mythid)
152       I     xx_bottomdrag_file, fname_bottomdrag, adfname_bottomdrag  cHFLUXM_CONTROL
      I   , mythid )  
153    
154  c  c--   Only the master thread will do I/O.
 c--     Only the master thread will do I/O.  
155        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
156    
157  c     >>> Write control vector <<<        if ( first ) then
158    c     >>> Initialise control vector for optimcycle=0 <<<
159  cph   this part was removed since it's not necessary            lxxadxx   = .TRUE.
160  cph   and causes huge amounts of wall clock time on parallel machines            ictrlgrad = 1
161              fcloc     = fmin
162              write(cfile(1:128),'(4a,i4.4)')
163         &         ctrlname(1:9),'_',yctrlid(1:10),
164         &         yctrlpospack, optimcycle
165              print *, 'ph-pack: packing ', ctrlname(1:9)
166          else
167  c     >>> Write gradient vector <<<  c     >>> Write gradient vector <<<
168        lxxadxx = .FALSE.            lxxadxx   = .FALSE.
169              ictrlgrad = 2
170            call mdsfindunit( cunit, mythid )            fcloc     = fc
171            write(cfile(1:128),'(4a,i4.4)')            write(cfile(1:128),'(4a,i4.4)')
172       &    costname(1:9),'_',yctrlid(1:10),'.opt',       &         costname(1:9),'_',yctrlid(1:10),
173       &    optimcycle       &         yctrlpospack, optimcycle
174              print *, 'ph-pack: packing ', costname(1:9)
175            open( cunit, file   = cfile,         endif
176       &               status = 'unknown',  
177       &               form   = 'unformatted',         call mdsfindunit( cunit, mythid )
178       &               access  = 'sequential'   )         open( cunit, file   = cfile,
179         &      status = 'unknown',
180         &      form   = 'unformatted',
181         &      access  = 'sequential'   )
182    
183  c--       Header information.  c--       Header information.
184            write(cunit) nvartype            write(cunit) nvartype
# Line 231  c--       Header information. Line 186  c--       Header information.
186            write(cunit) yctrlid            write(cunit) yctrlid
187            write(cunit) optimCycle            write(cunit) optimCycle
188            write(cunit) fc            write(cunit) fc
189    C     place holder of obsolete variable iG
190            write(cunit) 1            write(cunit) 1
191    C     place holder of obsolete variable jG
192            write(cunit) 1            write(cunit) 1
193            write(cunit) 1            write(cunit) nsx
194            write(cunit) 1            write(cunit) nsy
195            write(cunit) (nWetcGlobal(k), k=1,nr)            write(cunit) (nWetcGlobal(k), k=1,nr)
196            write(cunit) (nWetsGlobal(k), k=1,nr)            write(cunit) (nWetsGlobal(k), k=1,nr)
197            write(cunit) (nWetwGlobal(k), k=1,nr)            write(cunit) (nWetwGlobal(k), k=1,nr)
198  #ifdef ALLOW_CTRL_WETV  #ifdef ALLOW_CTRL_WETV
199            write(cunit) (nWetvGlobal(k), k=1,nr)            write(cunit) (nWetvGlobal(k), k=1,nr)
200  #endif  #endif
201    
202  #ifdef ALLOW_OBCSN_CONTROL  #ifdef ALLOW_OBCSN_CONTROL
203            write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)            write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
204  #endif  #endif
# Line 255  c--       Header information. Line 213  c--       Header information.
213  #endif  #endif
214            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
215            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
216            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (ncvarxmax(i),  i=1,maxcvars)
217            write(cunit) (ny,  i=1,maxcvars)            write(cunit) (ncvarymax(i),  i=1,maxcvars)
218            write(cunit) (ncvarnrmax(i), i=1,maxcvars)            write(cunit) (ncvarnrmax(i), i=1,maxcvars)
219            write(cunit) (ncvargrd(i),   i=1,maxcvars)            write(cunit) (ncvargrd(i),   i=1,maxcvars)
220            write(cunit)            write(cunit)
# Line 264  c--       Header information. Line 222  c--       Header information.
222  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
223            ivartype = 1            ivartype = 1
224            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
225            write(weighttype(1:80),'(a)') "wtheta"            write(weighttype(1:80),'(a)') "wthetaLev"
226            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
227       &         cunit, ivartype, adfname_theta, "hFacC",       &         cunit, ivartype, fname_theta(ictrlgrad), "maskCtrlC",
228       &         weighttype, wtheta, lxxadxx, mythid)       &         weighttype, wtheta, lxxadxx, mythid)
229  #endif  #endif
230    
231  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
232            ivartype = 2            ivartype = 2
233            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
234            write(weighttype(1:80),'(a)') "wsalt"            write(weighttype(1:80),'(a)') "wsaltLev"
235            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
236       &         cunit, ivartype, adfname_salt, "hFacC",       &         cunit, ivartype, fname_salt(ictrlgrad), "maskCtrlC",
237       &         weighttype, wsalt, lxxadxx, mythid)       &         weighttype, wsalt, lxxadxx, mythid)
238  #endif  #endif
239    
240  #if (defined (ALLOW_HFLUX_CONTROL) || \  #if (defined (ALLOW_HFLUX_CONTROL) || defined (ALLOW_HFLUX0_CONTROL))
      defined (ALLOW_HFLUX0_CONTROL))  
241            ivartype = 3            ivartype = 3
242            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
243            write(weighttype(1:80),'(a)') "whflux"            write(weighttype(1:80),'(a)') "whflux"
244            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
245       &         cunit, ivartype, adfname_hflux, "hFacC", weighttype,       &         cunit, ivartype, fname_hflux(ictrlgrad), "maskCtrlC",
246       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
247  #endif  #endif
248    
249  #if (defined (ALLOW_SFLUX_CONTROL) || \  #if (defined (ALLOW_SFLUX_CONTROL) || defined (ALLOW_SFLUX0_CONTROL))
      defined (ALLOW_SFLUX0_CONTROL))  
250            ivartype = 4            ivartype = 4
251            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
252            write(weighttype(1:80),'(a)') "wsflux"            write(weighttype(1:80),'(a)') "wsflux"
253            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
254       &         cunit, ivartype, adfname_sflux, "hFacC", weighttype,       &         cunit, ivartype, fname_sflux(ictrlgrad), "maskCtrlC",
255       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
256  #endif  #endif
257    
258  #if (defined (ALLOW_USTRESS_CONTROL) || \  #if (defined (ALLOW_USTRESS_CONTROL) || defined (ALLOW_TAUU0_CONTROL))
      defined (ALLOW_TAUU0_CONTROL))  
259            ivartype = 5            ivartype = 5
260            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
261            write(weighttype(1:80),'(a)') "wtauu"            write(weighttype(1:80),'(a)') "wtauu"
262            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
263       &         cunit, ivartype, adfname_tauu, "maskW", weighttype,       &         cunit, ivartype, fname_tauu(ictrlgrad), "maskCtrlW",
264       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
265  #endif  #endif
266    
267  #if (defined (ALLOW_VSTRESS_CONTROL) || \  #if (defined (ALLOW_VSTRESS_CONTROL) || defined (ALLOW_TAUV0_CONTROL))
      defined (ALLOW_TAUV0_CONTROL))  
268            ivartype = 6            ivartype = 6
269            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
270            write(weighttype(1:80),'(a)') "wtauv"            write(weighttype(1:80),'(a)') "wtauv"
271            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
272       &         cunit, ivartype, adfname_tauv, "maskS", weighttype,       &         cunit, ivartype, fname_tauv(ictrlgrad), "maskCtrlS",
273       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
274  #endif  #endif
275    
276  #ifdef ALLOW_ATEMP_CONTROL  #ifdef ALLOW_ATEMP_CONTROL
# Line 324  c--       Header information. Line 278  c--       Header information.
278            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
279            write(weighttype(1:80),'(a)') "watemp"            write(weighttype(1:80),'(a)') "watemp"
280            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
281       &         cunit, ivartype, adfname_atemp, "hFacC", weighttype,       &         cunit, ivartype, fname_atemp(ictrlgrad), "maskCtrlC",
282       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
283  #endif  #endif
284    
285  #ifdef ALLOW_AQH_CONTROL  #ifdef ALLOW_AQH_CONTROL
# Line 333  c--       Header information. Line 287  c--       Header information.
287            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
288            write(weighttype(1:80),'(a)') "waqh"            write(weighttype(1:80),'(a)') "waqh"
289            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
290       &         cunit, ivartype, adfname_aqh, "hFacC", weighttype,       &         cunit, ivartype, fname_aqh(ictrlgrad), "maskCtrlC",
291       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
292  #endif  #endif
293    
294  #ifdef ALLOW_UWIND_CONTROL  #ifdef ALLOW_UWIND_CONTROL
# Line 342  c--       Header information. Line 296  c--       Header information.
296            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
297            write(weighttype(1:80),'(a)') "wuwind"            write(weighttype(1:80),'(a)') "wuwind"
298            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
299       &         cunit, ivartype, adfname_uwind, "maskW", weighttype,       &         cunit, ivartype, fname_uwind(ictrlgrad), "maskCtrlC",
300       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
301  #endif  #endif
302    
303  #ifdef ALLOW_VWIND_CONTROL  #ifdef ALLOW_VWIND_CONTROL
# Line 351  c--       Header information. Line 305  c--       Header information.
305            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
306            write(weighttype(1:80),'(a)') "wvwind"            write(weighttype(1:80),'(a)') "wvwind"
307            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
308       &         cunit, ivartype, adfname_vwind, "maskS", weighttype,       &         cunit, ivartype, fname_vwind(ictrlgrad), "maskCtrlC",
309       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
310  #endif  #endif
311    
312  #ifdef ALLOW_OBCSN_CONTROL  #ifdef ALLOW_OBCSN_CONTROL
# Line 360  c--       Header information. Line 314  c--       Header information.
314            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
315            write(weighttype(1:80),'(a)') "wobcsn"            write(weighttype(1:80),'(a)') "wobcsn"
316            call ctrl_set_pack_xz(            call ctrl_set_pack_xz(
317       &         cunit, ivartype, adfname_obcsn, "maskobcsn",       &         cunit, ivartype, fname_obcsn(ictrlgrad), "maskobcsn",
318       &         weighttype, wobcsn, lxxadxx, mythid)       &         weighttype, wobcsn, lxxadxx, mythid)
319  #endif  #endif
320    
# Line 369  c--       Header information. Line 323  c--       Header information.
323            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
324            write(weighttype(1:80),'(a)') "wobcss"            write(weighttype(1:80),'(a)') "wobcss"
325            call ctrl_set_pack_xz(            call ctrl_set_pack_xz(
326       &         cunit, ivartype, adfname_obcss, "maskobcss",       &         cunit, ivartype, fname_obcss(ictrlgrad), "maskobcss",
327       &         weighttype, wobcss, lxxadxx, mythid)       &         weighttype, wobcss, lxxadxx, mythid)
328  #endif  #endif
329    
# Line 378  c--       Header information. Line 332  c--       Header information.
332            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
333            write(weighttype(1:80),'(a)') "wobcsw"            write(weighttype(1:80),'(a)') "wobcsw"
334            call ctrl_set_pack_yz(            call ctrl_set_pack_yz(
335       &         cunit, ivartype, adfname_obcsw, "maskobcsw",       &         cunit, ivartype, fname_obcsw(ictrlgrad), "maskobcsw",
336       &         weighttype, wobcsw, lxxadxx, mythid)       &         weighttype, wobcsw, lxxadxx, mythid)
337  #endif  #endif
338    
# Line 387  c--       Header information. Line 341  c--       Header information.
341            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
342            write(weighttype(1:80),'(a)') "wobcse"            write(weighttype(1:80),'(a)') "wobcse"
343            call ctrl_set_pack_yz(            call ctrl_set_pack_yz(
344       &         cunit, ivartype, adfname_obcse, "maskobcse",       &         cunit, ivartype, fname_obcse(ictrlgrad), "maskobcse",
345       &         weighttype, wobcse, lxxadxx, mythid)       &         weighttype, wobcse, lxxadxx, mythid)
346  #endif  #endif
347    
# Line 396  c--       Header information. Line 350  c--       Header information.
350            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
351            write(weighttype(1:80),'(a)') "wdiffkr"            write(weighttype(1:80),'(a)') "wdiffkr"
352            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
353       &         cunit, ivartype, adfname_diffkr, "hFacC",       &         cunit, ivartype, fname_diffkr(ictrlgrad), "maskCtrlC",
354       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wdiffkr, lxxadxx, mythid)
355  #endif  #endif
356    
357  #ifdef ALLOW_KAPGM_CONTROL  #ifdef ALLOW_KAPGM_CONTROL
# Line 405  c--       Header information. Line 359  c--       Header information.
359            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
360            write(weighttype(1:80),'(a)') "wkapgm"            write(weighttype(1:80),'(a)') "wkapgm"
361            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
362       &         cunit, ivartype, adfname_kapgm, "hFacC",       &         cunit, ivartype, fname_kapgm(ictrlgrad), "maskCtrlC",
363       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wkapgm, lxxadxx, mythid)
364  #endif  #endif
365    
366  #ifdef ALLOW_TR10_CONTROL  #ifdef ALLOW_TR10_CONTROL
# Line 414  c--       Header information. Line 368  c--       Header information.
368            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
369            write(weighttype(1:80),'(a)') "wtr1"            write(weighttype(1:80),'(a)') "wtr1"
370            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
371       &         cunit, ivartype, adfname_tr1, "hFacC",       &         cunit, ivartype, fname_tr1(ictrlgrad), "maskCtrlC",
372       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
373  #endif  #endif
374    
375  #ifdef ALLOW_SST0_CONTROL  #if (defined (ALLOW_SST_CONTROL) || defined (ALLOW_SST0_CONTROL))
376            ivartype = 18            ivartype = 18
377            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
378            write(weighttype(1:80),'(a)') "wsst0"            write(weighttype(1:80),'(a)') "wsst"
379            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
380       &         cunit, ivartype, adfname_sst, "hFacC", weighttype,       &         cunit, ivartype, fname_sst(ictrlgrad), "maskCtrlC",
381       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
382  #endif  #endif
383    
384  #ifdef ALLOW_SSS0_CONTROL  #if (defined (ALLOW_SSS_CONTROL) || defined (ALLOW_SSS0_CONTROL))
385            ivartype = 19            ivartype = 19
386            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
387            write(weighttype(1:80),'(a)') "wsss0"            write(weighttype(1:80),'(a)') "wsss"
388            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
389       &         cunit, ivartype, adfname_sss, "hFacC", weighttype,       &         cunit, ivartype, fname_sss(ictrlgrad),
390       &         lxxadxx, mythid)       &         "maskCtrlC", weighttype, lxxadxx, mythid)
391  #endif  #endif
392    
393  #ifdef ALLOW_HFACC_CONTROL  #ifdef ALLOW_DEPTH_CONTROL
394            ivartype = 20            ivartype = 20
395            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
396            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  
397            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
398       &         cunit, ivartype, adfname_hfacc, "hFacC", weighttype,       &         cunit, ivartype, fname_depth(ictrlgrad),
399       &         lxxadxx, mythid)       &         "maskCtrlC", weighttype, lxxadxx, mythid)
400  # endif  #endif /* ALLOW_DEPTH_CONTROL */
 #endif  
401    
402  #ifdef ALLOW_EFLUXY0_CONTROL  #ifdef ALLOW_EFLUXY0_CONTROL
403            ivartype = 21            ivartype = 21
404            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
405            write(weighttype(1:80),'(a)') "wefluxy0"            write(weighttype(1:80),'(a)') "wefluxy0"
406            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
407       &         cunit, ivartype, adfname_efluxy, "hFacS",       &         cunit, ivartype, fname_efluxy(ictrlgrad), "maskCtrlS",
408       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
409  #endif  #endif
410    
# Line 465  c--       Header information. Line 413  c--       Header information.
413            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
414            write(weighttype(1:80),'(a)') "wefluxp0"            write(weighttype(1:80),'(a)') "wefluxp0"
415            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
416       &         cunit, ivartype, adfname_efluxp, "hFacV",       &         cunit, ivartype, fname_efluxp(ictrlgrad), "maskhFacV",
417       &         weighttype, wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
418  #endif  #endif
419    
# Line 474  c--       Header information. Line 422  c--       Header information.
422            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
423            write(weighttype(1:80),'(a)') "wbottomdrag"            write(weighttype(1:80),'(a)') "wbottomdrag"
424            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
425       &         cunit, ivartype, adfname_bottomdrag, "hFacC", weighttype,       &      cunit, ivartype, fname_bottomdrag(ictrlgrad), "maskCtrlC",
426       &         lxxadxx, mythid)       &      weighttype, lxxadxx, mythid)
427    #endif
428    
429    #ifdef ALLOW_HFLUXM_CONTROL
430              ivartype = 24
431              write(weighttype(1:80),'(80a)') ' '
432              write(weighttype(1:80),'(a)') "whfluxm"
433              call ctrl_set_pack_xy(
434         &         cunit, ivartype, fname_hfluxm(ictrlgrad), "maskCtrlC",
435         &         weighttype, lxxadxx, mythid)
436    #endif
437    
438    #ifdef ALLOW_EDTAUX_CONTROL
439              ivartype = 25
440              write(weighttype(1:80),'(80a)') ' '
441              write(weighttype(1:80),'(a)') "wedtaux"
442              call ctrl_set_pack_xyz(
443         &         cunit, ivartype, fname_edtaux(ictrlgrad), "maskCtrlW",
444         &         weighttype, wedtaux, lxxadxx, mythid)
445    #endif
446    
447    #ifdef ALLOW_EDTAUY_CONTROL
448              ivartype = 26
449              write(weighttype(1:80),'(80a)') ' '
450              write(weighttype(1:80),'(a)') "wedtauy"
451              call ctrl_set_pack_xyz(
452         &         cunit, ivartype, fname_edtauy(ictrlgrad), "maskCtrlS",
453         &         weighttype, wedtauy, lxxadxx, mythid)
454    #endif
455    
456    #ifdef ALLOW_UVEL0_CONTROL
457              ivartype = 27
458              write(weighttype(1:80),'(80a)') ' '
459              write(weighttype(1:80),'(a)') "wuvel"
460              call ctrl_set_pack_xyz(
461         &         cunit, ivartype, fname_uvel(ictrlgrad), "maskCtrlW",
462         &         weighttype, wunit, lxxadxx, mythid)
463    #endif
464    
465    #ifdef ALLOW_VVEL0_CONTROL
466              ivartype = 28
467              write(weighttype(1:80),'(80a)') ' '
468              write(weighttype(1:80),'(a)') "wvvel"
469              call ctrl_set_pack_xyz(
470         &         cunit, ivartype, fname_vvel(ictrlgrad), "maskCtrlS",
471         &         weighttype, wunit, lxxadxx, mythid)
472    #endif
473    
474    #ifdef ALLOW_ETAN0_CONTROL
475              ivartype = 29
476              write(weighttype(1:80),'(80a)') ' '
477              write(weighttype(1:80),'(a)') "wetan"
478              call ctrl_set_pack_xy(
479         &         cunit, ivartype, fname_etan(ictrlgrad),
480         &         "maskCtrlC", weighttype, lxxadxx, mythid)
481    #endif
482    
483    #ifdef ALLOW_RELAXSST_CONTROL
484              ivartype = 30
485              write(weighttype(1:80),'(80a)') ' '
486              write(weighttype(1:80),'(a)') "wrelaxsst"
487              call ctrl_set_pack_xy(
488         &         cunit, ivartype, fname_relaxsst(ictrlgrad),
489         &         "maskCtrlC", weighttype, lxxadxx, mythid)
490    #endif
491    
492    #ifdef ALLOW_RELAXSSS_CONTROL
493              ivartype = 31
494              write(weighttype(1:80),'(80a)') ' '
495              write(weighttype(1:80),'(a)') "wrelaxsss"
496              call ctrl_set_pack_xy(
497         &         cunit, ivartype, fname_relaxsss(ictrlgrad),
498         &         "maskCtrlC", weighttype, lxxadxx, mythid)
499    #endif
500    
501    #ifdef ALLOW_PRECIP_CONTROL
502              ivartype = 32
503              write(weighttype(1:80),'(80a)') ' '
504              write(weighttype(1:80),'(a)') "wprecip"
505              call ctrl_set_pack_xy(
506         &         cunit, ivartype, fname_precip(ictrlgrad),
507         &         "maskCtrlC", weighttype, lxxadxx, mythid)
508    #endif
509    
510    #ifdef ALLOW_SWFLUX_CONTROL
511              ivartype = 33
512              write(weighttype(1:80),'(80a)') ' '
513              write(weighttype(1:80),'(a)') "wswflux"
514              call ctrl_set_pack_xy(
515         &         cunit, ivartype, fname_swflux(ictrlgrad),
516         &         "maskCtrlC", weighttype, lxxadxx, mythid)
517    #endif
518    
519    #ifdef ALLOW_SWDOWN_CONTROL
520              ivartype = 34
521              write(weighttype(1:80),'(80a)') ' '
522              write(weighttype(1:80),'(a)') "wswdown"
523              call ctrl_set_pack_xy(
524         &         cunit, ivartype, fname_swdown(ictrlgrad),
525         &         "maskCtrlC", weighttype, lxxadxx, mythid)
526    #endif
527    
528    #ifdef ALLOW_LWFLUX_CONTROL
529              ivartype = 35
530              write(weighttype(1:80),'(80a)') ' '
531              write(weighttype(1:80),'(a)') "wlwflux"
532              call ctrl_set_pack_xy(
533         &         cunit, ivartype, fname_lwflux(ictrlgrad),
534         &         "maskCtrlC", weighttype, lxxadxx, mythid)
535    #endif
536    
537    #ifdef ALLOW_LWDOWN_CONTROL
538              ivartype = 36
539              write(weighttype(1:80),'(80a)') ' '
540              write(weighttype(1:80),'(a)') "wlwdown"
541              call ctrl_set_pack_xy(
542         &         cunit, ivartype, fname_lwdown(ictrlgrad),
543         &         "maskCtrlC", weighttype, lxxadxx, mythid)
544    #endif
545    
546    #ifdef ALLOW_EVAP_CONTROL
547              ivartype = 37
548              write(weighttype(1:80),'(80a)') ' '
549              write(weighttype(1:80),'(a)') "wevap"
550              call ctrl_set_pack_xy(
551         &         cunit, ivartype, fname_evap(ictrlgrad),
552         &         "maskCtrlC", weighttype, lxxadxx, mythid)
553    #endif
554    
555    #ifdef ALLOW_SNOWPRECIP_CONTROL
556              ivartype = 38
557              write(weighttype(1:80),'(80a)') ' '
558              write(weighttype(1:80),'(a)') "wsnowprecip"
559              call ctrl_set_pack_xy(
560         &         cunit, ivartype, fname_snowprecip(ictrlgrad),
561         &         "maskCtrlC", weighttype, lxxadxx, mythid)
562    #endif
563    
564    #ifdef ALLOW_APRESSURE_CONTROL
565              ivartype = 39
566              write(weighttype(1:80),'(80a)') ' '
567              write(weighttype(1:80),'(a)') "wapressure"
568              call ctrl_set_pack_xy(
569         &         cunit, ivartype, fname_apressure(ictrlgrad),
570         &         "maskCtrlC", weighttype, lxxadxx, mythid)
571    #endif
572    
573    #ifdef ALLOW_RUNOFF_CONTROL
574              ivartype = 40
575              write(weighttype(1:80),'(80a)') ' '
576              write(weighttype(1:80),'(a)') "wrunoff"
577              call ctrl_set_pack_xy(
578         &         cunit, ivartype, fname_runoff(ictrlgrad),
579         &         "maskCtrlC", weighttype, lxxadxx, mythid)
580    #endif
581    
582    #ifdef ALLOW_SIAREA_CONTROL
583              ivartype = 41
584              write(weighttype(1:80),'(80a)') ' '
585              write(weighttype(1:80),'(a)') "wunit"
586              call ctrl_set_pack_xy(
587         &         cunit, ivartype, fname_siarea(ictrlgrad),
588         &         "maskCtrlC", weighttype, lxxadxx, mythid)
589    #endif
590    
591    #ifdef ALLOW_SIHEFF_CONTROL
592              ivartype = 42
593              write(weighttype(1:80),'(80a)') ' '
594              write(weighttype(1:80),'(a)') "wunit"
595              call ctrl_set_pack_xy(
596         &         cunit, ivartype, fname_siheff(ictrlgrad),
597         &         "maskCtrlC", weighttype, lxxadxx, mythid)
598    #endif
599    
600    #ifdef ALLOW_SIHSNOW_CONTROL
601              ivartype = 43
602              write(weighttype(1:80),'(80a)') ' '
603              write(weighttype(1:80),'(a)') "wunit"
604              call ctrl_set_pack_xy(
605         &         cunit, ivartype, fname_sihsnow(ictrlgrad),
606         &         "maskCtrlC", weighttype, lxxadxx, mythid)
607  #endif  #endif
608    
609            close ( cunit )            close ( cunit )
610    
611          _END_MASTER( mythid )          _END_MASTER( mythid )
612    
613    #endif /* EXCLUDE_CTRL_PACK */
614    
615        return        return
616        end        end
617    
Legend:
Removed from v.1.10  
changed lines
  Added in v.1.31
  ViewVC Help
Powered by ViewVC 1.1.22