/[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.7 by heimbach, Fri Mar 7 02:45:48 2003 UTC revision 1.37 by heimbach, Sun Mar 13 22:25:56 2011 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  CBOP        subroutine ctrl_pack( first, mythid )
8  C     !ROUTINE: ctrl_pack  
9  C     !INTERFACE:  c     ==================================================================
10        subroutine ctrl_pack( myiter, mytime, mythid )  c     SUBROUTINE ctrl_pack
11    c     ==================================================================
12  C     !DESCRIPTION: \bv  c
13  c     *=================================================================  c     o Compress the control vector such that only ocean points are
14  c     | SUBROUTINE ctrl_pack  c       written to file.
15  c     | Pack the control vector  c
16  c     | * All control variable and adjoint variable fields are  c     started: Christian Eckert eckert@mit.edu  10-Mar=2000
17  c     |   read from disk.  c
18  c     | * Wet points are extracted, and elements are  c     changed: Patrick Heimbach heimbach@mit.edu 06-Jun-2000
19  c     |   normalized (optional)  c              - Transferred some filename declarations
20  c     | * A single control vector containing only (normalized  c                from here to namelist in ctrl_init
21  c     |   wet points is written to file.  c  
22  c     *=================================================================  c              Patrick Heimbach heimbach@mit.edu 16-Jun-2000
23  C     \ev  c              - single file name convention with or without
24    c                ALLOW_ECCO_OPTIMIZATION
25    c
26    c              G. Gebbie, added open boundary control packing,
27    c                  gebbie@mit.edu  18 -Mar- 2003
28    c
29    c              heimbach@mit.edu totally restructured 28-Oct-2003
30    c
31    c     ==================================================================
32    c     SUBROUTINE ctrl_pack
33    c     ==================================================================
34    
 C     !USES:  
35        implicit none        implicit none
36    
37  c     == global variables ==  c     == global variables ==
# Line 29  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 60  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 124  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_kapredi_file, fname_kapredi, mythid)
134       I     xx_obcse_file, fname_obcse, adfname_obcse, mythid )        call ctrl_set_fname(xx_tr1_file, fname_tr1, mythid)
135        call ctrl_set_fname(        call ctrl_set_fname(xx_sst_file, fname_sst, mythid)
136       I     xx_diffkr_file, fname_diffkr, adfname_diffkr, mythid )        call ctrl_set_fname(xx_sss_file, fname_sss, mythid)
137        call ctrl_set_fname(        call ctrl_set_fname(xx_depth_file, fname_depth, mythid)
138       I     xx_kapgm_file, fname_kapgm, adfname_kapgm, mythid )        call ctrl_set_fname(xx_efluxy_file, fname_efluxy, mythid)
139        call ctrl_set_fname(        call ctrl_set_fname(xx_efluxp_file, fname_efluxp, mythid)
140       I     xx_tr1_file, fname_tr1, adfname_tr1, mythid )        call ctrl_set_fname(xx_bottomdrag_file, fname_bottomdrag, mythid)
141        call ctrl_set_fname(        call ctrl_set_fname(xx_edtaux_file, fname_edtaux, mythid)
142       I     xx_sst_file, fname_sst, adfname_sst, mythid )        call ctrl_set_fname(xx_edtauy_file, fname_edtauy, mythid)
143        call ctrl_set_fname(        call ctrl_set_fname(xx_uvel_file, fname_uvel, mythid)
144       I     xx_sss_file, fname_sss, adfname_sss, mythid )        call ctrl_set_fname(xx_vvel_file, fname_vvel, mythid)
145        call ctrl_set_fname(        call ctrl_set_fname(xx_etan_file, fname_etan, mythid)
146       I     xx_hfacc_file, fname_hfacc, adfname_hfacc, mythid )        call ctrl_set_fname(xx_relaxsst_file, fname_relaxsst, mythid)
147        call ctrl_set_fname(        call ctrl_set_fname(xx_relaxsss_file, fname_relaxsss, mythid)
148       I     xx_efluxy_file, fname_efluxy, adfname_efluxy, mythid )        call ctrl_set_fname(xx_siarea_file, fname_siarea, mythid)
149        call ctrl_set_fname(        call ctrl_set_fname(xx_siheff_file, fname_siheff, mythid)
150       I     xx_efluxp_file, fname_efluxp, adfname_efluxp, mythid )        call ctrl_set_fname(xx_sihsnow_file, fname_sihsnow, mythid)
151        call ctrl_set_fname(  cHFLUXM_CONTROL
152       I     xx_bottomdrag_file, fname_bottomdrag, adfname_bottomdrag        call ctrl_set_fname(xx_hfluxm_file, fname_hfluxm, mythid)
153       I   , mythid )  cHFLUXM_CONTROL
154    
155  c  c--   Only the master thread will do I/O.
 c--     Only the master thread will do I/O.  
156        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
157    
158  c     >>> Write control vector <<<        if ( first ) then
159    c     >>> Initialise control vector for optimcycle=0 <<<
160  cph   this part was removed since it's not necessary            lxxadxx   = .TRUE.
161  cph   and causes huge amounts of wall clock time on parallel machines            ictrlgrad = 1
162              fcloc     = fmin
163              write(cfile(1:128),'(4a,i4.4)')
164         &         ctrlname(1:9),'_',yctrlid(1:10),
165         &         yctrlpospack, optimcycle
166              print *, 'ph-pack: packing ', ctrlname(1:9)
167          else
168  c     >>> Write gradient vector <<<  c     >>> Write gradient vector <<<
169        lxxadxx = .FALSE.            lxxadxx   = .FALSE.
170              ictrlgrad = 2
171            call mdsfindunit( cunit, mythid )            fcloc     = fc
172            write(cfile(1:128),'(4a,i4.4)')            write(cfile(1:128),'(4a,i4.4)')
173       &    costname(1:9),'_',yctrlid(1:10),'.opt',       &         costname(1:9),'_',yctrlid(1:10),
174       &    optimcycle       &         yctrlpospack, optimcycle
175              print *, 'ph-pack: packing ', costname(1:9)
176            open( cunit, file   = cfile,         endif
177       &               status = 'unknown',  
178       &               form   = 'unformatted',  c--   Only Proc 0 will do I/O.
179       &               access  = 'sequential'   )        IF ( myProcId .eq. 0 ) THEN
180    
181           call mdsfindunit( cunit, mythid )
182           open( cunit, file   = cfile,
183         &      status = 'unknown',
184         &      form   = 'unformatted',
185         &      access  = 'sequential'   )
186    
187  c--       Header information.  c--       Header information.
188            write(cunit) nvartype            write(cunit) nvartype
# Line 215  c--       Header information. Line 190  c--       Header information.
190            write(cunit) yctrlid            write(cunit) yctrlid
191            write(cunit) optimCycle            write(cunit) optimCycle
192            write(cunit) fc            write(cunit) fc
193    C     place holder of obsolete variable iG
194            write(cunit) 1            write(cunit) 1
195    C     place holder of obsolete variable jG
196            write(cunit) 1            write(cunit) 1
197            write(cunit) 1            write(cunit) nsx
198            write(cunit) 1            write(cunit) nsy
199            write(cunit) (nWetcGlobal(k), k=1,nr)            write(cunit) (nWetcGlobal(k), k=1,nr)
200            write(cunit) (nWetsGlobal(k), k=1,nr)            write(cunit) (nWetsGlobal(k), k=1,nr)
201            write(cunit) (nWetwGlobal(k), k=1,nr)            write(cunit) (nWetwGlobal(k), k=1,nr)
202  #ifdef ALLOW_CTRL_WETV  #ifdef ALLOW_CTRL_WETV
203            write(cunit) (nWetvGlobal(k), k=1,nr)            write(cunit) (nWetvGlobal(k), k=1,nr)
204  #endif  #endif
205    
206  #ifdef ALLOW_OBCSN_CONTROL  #ifdef ALLOW_OBCSN_CONTROL
207            write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)            write(cunit) ((nWetobcsnGlo(k,iobcs), k=1,nr),iobcs= 1,nobcs)
208  #endif  #endif
# Line 239  c--       Header information. Line 217  c--       Header information.
217  #endif  #endif
218            write(cunit) (ncvarindex(i), i=1,maxcvars)            write(cunit) (ncvarindex(i), i=1,maxcvars)
219            write(cunit) (ncvarrecs(i),  i=1,maxcvars)            write(cunit) (ncvarrecs(i),  i=1,maxcvars)
220            write(cunit) (nx,  i=1,maxcvars)            write(cunit) (ncvarxmax(i),  i=1,maxcvars)
221            write(cunit) (ny,  i=1,maxcvars)            write(cunit) (ncvarymax(i),  i=1,maxcvars)
222            write(cunit) (ncvarnrmax(i), i=1,maxcvars)            write(cunit) (ncvarnrmax(i), i=1,maxcvars)
223            write(cunit) (ncvargrd(i),   i=1,maxcvars)            write(cunit) (ncvargrd(i),   i=1,maxcvars)
224            write(cunit)            write(cunit)
225    
226    #ifdef ALLOW_PACKUNPACK_METHOD2
227          ENDIF
228          _END_MASTER( mythid )
229          _BARRIER
230    #endif
231    
232  #ifdef ALLOW_THETA0_CONTROL  #ifdef ALLOW_THETA0_CONTROL
233            ivartype = 1            ivartype = 1
234              write(weighttype(1:80),'(80a)') ' '
235              write(weighttype(1:80),'(a)') "wthetaLev"
236            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
237       &         cunit, ivartype, adfname_theta, "hFacC",       &         cunit, ivartype, fname_theta(ictrlgrad), "maskCtrlC",
238       &         wtheta, lxxadxx, mythid)       &         weighttype, wtheta, lxxadxx, mythid)
239  #endif  #endif
240    
241  #ifdef ALLOW_SALT0_CONTROL  #ifdef ALLOW_SALT0_CONTROL
242            ivartype = 2            ivartype = 2
243              write(weighttype(1:80),'(80a)') ' '
244              write(weighttype(1:80),'(a)') "wsaltLev"
245            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
246       &         cunit, ivartype, adfname_salt, "hFacC",       &         cunit, ivartype, fname_salt(ictrlgrad), "maskCtrlC",
247       &         wsalt, lxxadxx, mythid)       &         weighttype, wsalt, lxxadxx, mythid)
248  #endif  #endif
249    
250  #if (defined (ALLOW_HFLUX_CONTROL) || \  #if (defined (ALLOW_HFLUX_CONTROL) || defined (ALLOW_HFLUX0_CONTROL))
      defined (ALLOW_HFLUX0_CONTROL))  
251            ivartype = 3            ivartype = 3
252            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
253            write(weighttype(1:80),'(a)') "whflux"            write(weighttype(1:80),'(a)') "whflux"
254            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
255       &         cunit, ivartype, adfname_hflux, "hFacC", weighttype,       &         cunit, ivartype, fname_hflux(ictrlgrad), "maskCtrlC",
256       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
257  #endif  #endif
258    
259  #if (defined (ALLOW_SFLUX_CONTROL) || \  #if (defined (ALLOW_SFLUX_CONTROL) || defined (ALLOW_SFLUX0_CONTROL))
      defined (ALLOW_SFLUX0_CONTROL))  
260            ivartype = 4            ivartype = 4
261            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
262            write(weighttype(1:80),'(a)') "wsflux"            write(weighttype(1:80),'(a)') "wsflux"
263            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
264       &         cunit, ivartype, adfname_sflux, "hFacC", weighttype,       &         cunit, ivartype, fname_sflux(ictrlgrad), "maskCtrlC",
265       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
266  #endif  #endif
267    
268  #if (defined (ALLOW_USTRESS_CONTROL) || \  #if (defined (ALLOW_USTRESS_CONTROL) || defined (ALLOW_TAUU0_CONTROL))
      defined (ALLOW_TAUU0_CONTROL))  
269            ivartype = 5            ivartype = 5
270            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
271            write(weighttype(1:80),'(a)') "wtauu"            write(weighttype(1:80),'(a)') "wtauu"
272            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
273       &         cunit, ivartype, adfname_tauu, "maskW", weighttype,  #ifndef ALLOW_ROTATE_UV_CONTROLS
274       &         lxxadxx, mythid)       &         cunit, ivartype, fname_tauu(ictrlgrad), "maskCtrlW",
275    #else
276         &         cunit, ivartype, fname_tauu(ictrlgrad), "maskCtrlC",
277    #endif
278         &         weighttype, lxxadxx, mythid)
279  #endif  #endif
280    
281  #if (defined (ALLOW_VSTRESS_CONTROL) || \  #if (defined (ALLOW_VSTRESS_CONTROL) || defined (ALLOW_TAUV0_CONTROL))
      defined (ALLOW_TAUV0_CONTROL))  
282            ivartype = 6            ivartype = 6
283            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
284            write(weighttype(1:80),'(a)') "wtauv"            write(weighttype(1:80),'(a)') "wtauv"
285            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
286       &         cunit, ivartype, adfname_tauv, "maskS", weighttype,  #ifndef ALLOW_ROTATE_UV_CONTROLS
287       &         lxxadxx, mythid)       &         cunit, ivartype, fname_tauv(ictrlgrad), "maskCtrlS",
288    #else
289         &         cunit, ivartype, fname_tauv(ictrlgrad), "maskCtrlC",
290    #endif
291         &         weighttype, lxxadxx, mythid)
292  #endif  #endif
293    
294  #ifdef ALLOW_ATEMP_CONTROL  #ifdef ALLOW_ATEMP_CONTROL
# Line 304  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)') "watemp"            write(weighttype(1:80),'(a)') "watemp"
298            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
299       &         cunit, ivartype, adfname_atemp, "hFacC", weighttype,       &         cunit, ivartype, fname_atemp(ictrlgrad), "maskCtrlC",
300       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
301  #endif  #endif
302    
303  #ifdef ALLOW_AQH_CONTROL  #ifdef ALLOW_AQH_CONTROL
# Line 313  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)') "waqh"            write(weighttype(1:80),'(a)') "waqh"
307            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
308       &         cunit, ivartype, adfname_aqh, "hFacC", weighttype,       &         cunit, ivartype, fname_aqh(ictrlgrad), "maskCtrlC",
309       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
310  #endif  #endif
311    
312  #ifdef ALLOW_UWIND_CONTROL  #ifdef ALLOW_UWIND_CONTROL
# Line 322  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)') "wuwind"            write(weighttype(1:80),'(a)') "wuwind"
316            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
317       &         cunit, ivartype, adfname_uwind, "maskW", weighttype,       &         cunit, ivartype, fname_uwind(ictrlgrad), "maskCtrlC",
318       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
319  #endif  #endif
320    
321  #ifdef ALLOW_VWIND_CONTROL  #ifdef ALLOW_VWIND_CONTROL
# Line 331  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)') "wvwind"            write(weighttype(1:80),'(a)') "wvwind"
325            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
326       &         cunit, ivartype, adfname_vwind, "maskS", weighttype,       &         cunit, ivartype, fname_vwind(ictrlgrad), "maskCtrlC",
327       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
328  #endif  #endif
329    
330  #ifdef ALLOW_OBCSN_CONTROL  #ifdef ALLOW_OBCSN_CONTROL
331            ivartype = 11            ivartype = 11
332              write(weighttype(1:80),'(80a)') ' '
333              write(weighttype(1:80),'(a)') "wobcsn"
334            call ctrl_set_pack_xz(            call ctrl_set_pack_xz(
335       &         cunit, ivartype, adfname_obcsn, "maskobcsn",       &         cunit, ivartype, fname_obcsn(ictrlgrad), "maskobcsn",
336       &         wobcsn, lxxadxx, mythid)       &         weighttype, wobcsn, lxxadxx, mythid)
337  #endif  #endif
338    
339  #ifdef ALLOW_OBCSS_CONTROL  #ifdef ALLOW_OBCSS_CONTROL
340            ivartype = 12            ivartype = 12
341              write(weighttype(1:80),'(80a)') ' '
342              write(weighttype(1:80),'(a)') "wobcss"
343            call ctrl_set_pack_xz(            call ctrl_set_pack_xz(
344       &         cunit, ivartype, adfname_obcss, "maskobcss",       &         cunit, ivartype, fname_obcss(ictrlgrad), "maskobcss",
345       &         wobcss, lxxadxx, mythid)       &         weighttype, wobcss, lxxadxx, mythid)
346  #endif  #endif
347    
348  #ifdef ALLOW_OBCSW_CONTROL  #ifdef ALLOW_OBCSW_CONTROL
349            ivartype = 13            ivartype = 13
350              write(weighttype(1:80),'(80a)') ' '
351              write(weighttype(1:80),'(a)') "wobcsw"
352            call ctrl_set_pack_yz(            call ctrl_set_pack_yz(
353       &         cunit, ivartype, adfname_obcsw, "maskobcsw",       &         cunit, ivartype, fname_obcsw(ictrlgrad), "maskobcsw",
354       &         wobcsw, lxxadxx, mythid)       &         weighttype, wobcsw, lxxadxx, mythid)
355  #endif  #endif
356    
357  #ifdef ALLOW_OBCSE_CONTROL  #ifdef ALLOW_OBCSE_CONTROL
358            ivartype = 14            ivartype = 14
359              write(weighttype(1:80),'(80a)') ' '
360              write(weighttype(1:80),'(a)') "wobcse"
361            call ctrl_set_pack_yz(            call ctrl_set_pack_yz(
362       &         cunit, ivartype, adfname_obcse, "maskobcse",       &         cunit, ivartype, fname_obcse(ictrlgrad), "maskobcse",
363       &         wobcse, lxxadxx, mythid)       &         weighttype, wobcse, lxxadxx, mythid)
364  #endif  #endif
365    
366  #ifdef ALLOW_DIFFKR_CONTROL  #ifdef ALLOW_DIFFKR_CONTROL
367            ivartype = 15            ivartype = 15
368              write(weighttype(1:80),'(80a)') ' '
369              write(weighttype(1:80),'(a)') "wdiffkr"
370            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
371       &         cunit, ivartype, adfname_diffkr, "hFacC",       &         cunit, ivartype, fname_diffkr(ictrlgrad), "maskCtrlC",
372       &         wunit, lxxadxx, mythid)       &         weighttype, wdiffkr, lxxadxx, mythid)
373  #endif  #endif
374    
375  #ifdef ALLOW_KAPGM_CONTROL  #ifdef ALLOW_KAPGM_CONTROL
376            ivartype = 16            ivartype = 16
377              write(weighttype(1:80),'(80a)') ' '
378              write(weighttype(1:80),'(a)') "wkapgm"
379            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
380       &         cunit, ivartype, adfname_kapgm, "hFacC",       &         cunit, ivartype, fname_kapgm(ictrlgrad), "maskCtrlC",
381       &         wunit, lxxadxx, mythid)       &         weighttype, wkapgm, lxxadxx, mythid)
382  #endif  #endif
383    
384  #ifdef ALLOW_TR10_CONTROL  #ifdef ALLOW_TR10_CONTROL
385            ivartype = 17            ivartype = 17
386              write(weighttype(1:80),'(80a)') ' '
387              write(weighttype(1:80),'(a)') "wtr1"
388            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
389       &         cunit, ivartype, adfname_tr1, "hFacC",       &         cunit, ivartype, fname_tr1(ictrlgrad), "maskCtrlC",
390       &         wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
391  #endif  #endif
392    
393  #ifdef ALLOW_SST0_CONTROL  #if (defined (ALLOW_SST_CONTROL) || defined (ALLOW_SST0_CONTROL))
394            ivartype = 18            ivartype = 18
395            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
396            write(weighttype(1:80),'(a)') "wsst0"            write(weighttype(1:80),'(a)') "wsst"
397            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
398       &         cunit, ivartype, adfname_sst0, "hFacC", weighttype,       &         cunit, ivartype, fname_sst(ictrlgrad), "maskCtrlC",
399       &         lxxadxx, mythid)       &         weighttype, lxxadxx, mythid)
400  #endif  #endif
401    
402  #ifdef ALLOW_SSS0_CONTROL  #if (defined (ALLOW_SSS_CONTROL) || defined (ALLOW_SSS0_CONTROL))
403            ivartype = 19            ivartype = 19
404            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
405            write(weighttype(1:80),'(a)') "wsss0"            write(weighttype(1:80),'(a)') "wsss"
406            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
407       &         cunit, ivartype, adfname_sss0, "hFacC", weighttype,       &         cunit, ivartype, fname_sss(ictrlgrad),
408       &         lxxadxx, mythid)       &         "maskCtrlC", weighttype, lxxadxx, mythid)
409  #endif  #endif
410    
411  #ifdef ALLOW_HFACC_CONTROL  #ifdef ALLOW_DEPTH_CONTROL
412            ivartype = 20            ivartype = 20
 #ifdef ALLOW_HFACC3D_CONTROL  
           call ctrl_set_pack_xyz(  
      &         cunit, ivartype, adfname_hfacc, "hFacC",  
      &         wunit, lxxadxx, mythid)  
 #else  
413            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
414            write(weighttype(1:80),'(a)') "whfacc"            write(weighttype(1:80),'(a)') "wdepth"
415            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
416       &         cunit, ivartype, adfname_hfacc, "hFacC", weighttype,       &         cunit, ivartype, fname_depth(ictrlgrad),
417       &         lxxadxx, mythid)       &         "maskCtrlC", weighttype, lxxadxx, mythid)
418  #endif  #endif /* ALLOW_DEPTH_CONTROL */
 #endif  
419    
420  #ifdef ALLOW_EFLUXY0_CONTROL  #ifdef ALLOW_EFLUXY0_CONTROL
421            ivartype = 21            ivartype = 21
422              write(weighttype(1:80),'(80a)') ' '
423              write(weighttype(1:80),'(a)') "wefluxy0"
424            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
425       &         cunit, ivartype, adfname_efluxy, "hFacS",       &         cunit, ivartype, fname_efluxy(ictrlgrad), "maskCtrlS",
426       &         wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
427  #endif  #endif
428    
429  #ifdef ALLOW_EFLUXP0_CONTROL  #ifdef ALLOW_EFLUXP0_CONTROL
430            ivartype = 22            ivartype = 22
431              write(weighttype(1:80),'(80a)') ' '
432              write(weighttype(1:80),'(a)') "wefluxp0"
433            call ctrl_set_pack_xyz(            call ctrl_set_pack_xyz(
434       &         cunit, ivartype, adfname_efluxp, "hFacV",       &         cunit, ivartype, fname_efluxp(ictrlgrad), "maskhFacV",
435       &         wunit, lxxadxx, mythid)       &         weighttype, wunit, lxxadxx, mythid)
436  #endif  #endif
437    
438  #ifdef ALLOW_BOTTOMDRAG_CONTROL  #ifdef ALLOW_BOTTOMDRAG_CONTROL
# Line 436  c--       Header information. Line 440  c--       Header information.
440            write(weighttype(1:80),'(80a)') ' '            write(weighttype(1:80),'(80a)') ' '
441            write(weighttype(1:80),'(a)') "wbottomdrag"            write(weighttype(1:80),'(a)') "wbottomdrag"
442            call ctrl_set_pack_xy(            call ctrl_set_pack_xy(
443       &         cunit, ivartype, adfname_bottomdrag, "hFacC", weighttype,       &      cunit, ivartype, fname_bottomdrag(ictrlgrad), "maskCtrlC",
444       &         lxxadxx, mythid)       &      weighttype, lxxadxx, mythid)
445  #endif  #endif
446    
447            close ( cunit )  #ifdef ALLOW_HFLUXM_CONTROL
448              ivartype = 24
449              write(weighttype(1:80),'(80a)') ' '
450              write(weighttype(1:80),'(a)') "whfluxm"
451              call ctrl_set_pack_xy(
452         &         cunit, ivartype, fname_hfluxm(ictrlgrad), "maskCtrlC",
453         &         weighttype, lxxadxx, mythid)
454    #endif
455    
456    #ifdef ALLOW_EDDYPSI_CONTROL
457              ivartype = 25
458              write(weighttype(1:80),'(80a)') ' '
459              write(weighttype(1:80),'(a)') "wedtaux"
460              call ctrl_set_pack_xyz(
461         &         cunit, ivartype, fname_edtaux(ictrlgrad), "maskCtrlW",
462         &         weighttype, wedtaux, lxxadxx, mythid)
463    
464              ivartype = 26
465              write(weighttype(1:80),'(80a)') ' '
466              write(weighttype(1:80),'(a)') "wedtauy"
467              call ctrl_set_pack_xyz(
468         &         cunit, ivartype, fname_edtauy(ictrlgrad), "maskCtrlS",
469         &         weighttype, wedtauy, lxxadxx, mythid)
470    #endif
471    
472    #ifdef ALLOW_UVEL0_CONTROL
473              ivartype = 27
474              write(weighttype(1:80),'(80a)') ' '
475              write(weighttype(1:80),'(a)') "wuvel"
476              call ctrl_set_pack_xyz(
477         &         cunit, ivartype, fname_uvel(ictrlgrad), "maskCtrlW",
478         &         weighttype, wuvel, lxxadxx, mythid)
479    #endif
480    
481    #ifdef ALLOW_VVEL0_CONTROL
482              ivartype = 28
483              write(weighttype(1:80),'(80a)') ' '
484              write(weighttype(1:80),'(a)') "wvvel"
485              call ctrl_set_pack_xyz(
486         &         cunit, ivartype, fname_vvel(ictrlgrad), "maskCtrlS",
487         &         weighttype, wvvel, lxxadxx, mythid)
488    #endif
489    
490    #ifdef ALLOW_ETAN0_CONTROL
491              ivartype = 29
492              write(weighttype(1:80),'(80a)') ' '
493              write(weighttype(1:80),'(a)') "wetan"
494              call ctrl_set_pack_xy(
495         &         cunit, ivartype, fname_etan(ictrlgrad),
496         &         "maskCtrlC", weighttype, lxxadxx, mythid)
497    #endif
498    
499    #ifdef ALLOW_RELAXSST_CONTROL
500              ivartype = 30
501              write(weighttype(1:80),'(80a)') ' '
502              write(weighttype(1:80),'(a)') "wrelaxsst"
503              call ctrl_set_pack_xy(
504         &         cunit, ivartype, fname_relaxsst(ictrlgrad),
505         &         "maskCtrlC", weighttype, lxxadxx, mythid)
506    #endif
507    
508    #ifdef ALLOW_RELAXSSS_CONTROL
509              ivartype = 31
510              write(weighttype(1:80),'(80a)') ' '
511              write(weighttype(1:80),'(a)') "wrelaxsss"
512              call ctrl_set_pack_xy(
513         &         cunit, ivartype, fname_relaxsss(ictrlgrad),
514         &         "maskCtrlC", weighttype, lxxadxx, mythid)
515    #endif
516    
517    #ifdef ALLOW_PRECIP_CONTROL
518              ivartype = 32
519              write(weighttype(1:80),'(80a)') ' '
520              write(weighttype(1:80),'(a)') "wprecip"
521              call ctrl_set_pack_xy(
522         &         cunit, ivartype, fname_precip(ictrlgrad),
523         &         "maskCtrlC", weighttype, lxxadxx, mythid)
524    #endif
525    
526    #ifdef ALLOW_SWFLUX_CONTROL
527              ivartype = 33
528              write(weighttype(1:80),'(80a)') ' '
529              write(weighttype(1:80),'(a)') "wswflux"
530              call ctrl_set_pack_xy(
531         &         cunit, ivartype, fname_swflux(ictrlgrad),
532         &         "maskCtrlC", weighttype, lxxadxx, mythid)
533    #endif
534    
535    #ifdef ALLOW_SWDOWN_CONTROL
536              ivartype = 34
537              write(weighttype(1:80),'(80a)') ' '
538              write(weighttype(1:80),'(a)') "wswdown"
539              call ctrl_set_pack_xy(
540         &         cunit, ivartype, fname_swdown(ictrlgrad),
541         &         "maskCtrlC", weighttype, lxxadxx, mythid)
542    #endif
543    
544    #ifdef ALLOW_LWFLUX_CONTROL
545              ivartype = 35
546              write(weighttype(1:80),'(80a)') ' '
547              write(weighttype(1:80),'(a)') "wlwflux"
548              call ctrl_set_pack_xy(
549         &         cunit, ivartype, fname_lwflux(ictrlgrad),
550         &         "maskCtrlC", weighttype, lxxadxx, mythid)
551    #endif
552    
553    #ifdef ALLOW_LWDOWN_CONTROL
554              ivartype = 36
555              write(weighttype(1:80),'(80a)') ' '
556              write(weighttype(1:80),'(a)') "wlwdown"
557              call ctrl_set_pack_xy(
558         &         cunit, ivartype, fname_lwdown(ictrlgrad),
559         &         "maskCtrlC", weighttype, lxxadxx, mythid)
560    #endif
561    
562    #ifdef ALLOW_EVAP_CONTROL
563              ivartype = 37
564              write(weighttype(1:80),'(80a)') ' '
565              write(weighttype(1:80),'(a)') "wevap"
566              call ctrl_set_pack_xy(
567         &         cunit, ivartype, fname_evap(ictrlgrad),
568         &         "maskCtrlC", weighttype, lxxadxx, mythid)
569    #endif
570    
571    #ifdef ALLOW_SNOWPRECIP_CONTROL
572              ivartype = 38
573              write(weighttype(1:80),'(80a)') ' '
574              write(weighttype(1:80),'(a)') "wsnowprecip"
575              call ctrl_set_pack_xy(
576         &         cunit, ivartype, fname_snowprecip(ictrlgrad),
577         &         "maskCtrlC", weighttype, lxxadxx, mythid)
578    #endif
579    
580    #ifdef ALLOW_APRESSURE_CONTROL
581              ivartype = 39
582              write(weighttype(1:80),'(80a)') ' '
583              write(weighttype(1:80),'(a)') "wapressure"
584              call ctrl_set_pack_xy(
585         &         cunit, ivartype, fname_apressure(ictrlgrad),
586         &         "maskCtrlC", weighttype, lxxadxx, mythid)
587    #endif
588    
589    #ifdef ALLOW_RUNOFF_CONTROL
590              ivartype = 40
591              write(weighttype(1:80),'(80a)') ' '
592              write(weighttype(1:80),'(a)') "wrunoff"
593              call ctrl_set_pack_xy(
594         &         cunit, ivartype, fname_runoff(ictrlgrad),
595         &         "maskCtrlC", weighttype, lxxadxx, mythid)
596    #endif
597    
598    #ifdef ALLOW_SIAREA_CONTROL
599              ivartype = 41
600              write(weighttype(1:80),'(80a)') ' '
601              write(weighttype(1:80),'(a)') "wunit"
602              call ctrl_set_pack_xy(
603         &         cunit, ivartype, fname_siarea(ictrlgrad),
604         &         "maskCtrlC", weighttype, lxxadxx, mythid)
605    #endif
606    
607    #ifdef ALLOW_SIHEFF_CONTROL
608              ivartype = 42
609              write(weighttype(1:80),'(80a)') ' '
610              write(weighttype(1:80),'(a)') "wunit"
611              call ctrl_set_pack_xy(
612         &         cunit, ivartype, fname_siheff(ictrlgrad),
613         &         "maskCtrlC", weighttype, lxxadxx, mythid)
614    #endif
615    
616    #ifdef ALLOW_SIHSNOW_CONTROL
617              ivartype = 43
618              write(weighttype(1:80),'(80a)') ' '
619              write(weighttype(1:80),'(a)') "wunit"
620              call ctrl_set_pack_xy(
621         &         cunit, ivartype, fname_sihsnow(ictrlgrad),
622         &         "maskCtrlC", weighttype, lxxadxx, mythid)
623    #endif
624    
625    #ifdef ALLOW_KAPREDI_CONTROL
626              ivartype = 44
627              write(weighttype(1:80),'(80a)') ' '
628              write(weighttype(1:80),'(a)') "wkapredi"
629              call ctrl_set_pack_xyz(
630         &         cunit, ivartype, fname_kapredi(ictrlgrad), "maskCtrlC",
631         &         weighttype, wkapredi, lxxadxx, mythid)
632    #endif
633    
634    #ifdef ALLOW_PACKUNPACK_METHOD2
635          _BEGIN_MASTER( mythid )
636          IF ( myProcId .eq. 0 ) THEN
637    #endif
638    
639          _END_MASTER( mythid )         close ( cunit )
640           ENDIF !IF ( myProcId .eq. 0 )
641           _END_MASTER( mythid )
642          _BARRIER
643    #endif /* EXCLUDE_CTRL_PACK */
644    
645        return        return
646        end        end
Legend:
Removed from v.1.7  
changed lines
  Added in v.1.37
  ViewVC Help
Powered by ViewVC 1.1.22