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

Annotation of /MITgcm/pkg/ctrl/ctrl_set_pack_xyz.F

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

Revision 1.7 - (hide annotations) (download)
Thu Nov 6 22:05:08 2003 UTC (20 years, 7 months ago) by heimbach
Branch: MAIN
CVS Tags: checkpoint52l_pre, hrcube4, hrcube5, checkpoint52d_pre, checkpoint52j_pre, checkpoint54d_post, checkpoint54e_post, checkpoint52l_post, checkpoint52k_post, checkpoint55, checkpoint54, checkpoint53, checkpoint52, checkpoint52f_post, checkpoint54f_post, checkpoint55i_post, checkpoint52i_pre, hrcube_1, hrcube_2, hrcube_3, checkpoint55c_post, checkpoint52e_pre, checkpoint52e_post, checkpoint53d_post, checkpoint52b_pre, checkpoint54b_post, checkpoint52m_post, checkpoint55g_post, checkpoint52b_post, checkpoint52c_post, checkpoint52f_pre, checkpoint55d_post, checkpoint54a_pre, checkpoint53c_post, checkpoint55d_pre, checkpoint55j_post, checkpoint54a_post, checkpoint55h_post, checkpoint55b_post, checkpoint53a_post, checkpoint55f_post, checkpoint52d_post, checkpoint53g_post, checkpoint52a_pre, checkpoint52i_post, checkpoint52h_pre, checkpoint53f_post, checkpoint52j_post, branch-netcdf, checkpoint52n_post, checkpoint53b_pre, checkpoint55a_post, checkpoint53b_post, checkpoint52a_post, ecco_c52_e35, checkpoint53d_pre, checkpoint55e_post, checkpoint54c_post, checkpoint51u_post
Branch point for: netcdf-sm0
Changes since 1.6: +1 -6 lines 
o merging from ecco-branch
o cleaned some cross-dependencies and updated CPP options
1 heimbach 1.2
2     #include "CTRL_CPPOPTIONS.h"
3    
4     subroutine ctrl_set_pack_xyz(
5 heimbach 1.4 & cunit, ivartype, fname, masktype, weighttype,
6 heimbach 1.2 & weightfld, lxxadxx, mythid)
7    
8     c ==================================================================
9     c SUBROUTINE ctrl_set_pack_xyz
10     c ==================================================================
11     c
12     c o Compress the control vector such that only ocean points are
13     c written to file.
14     c
15 heimbach 1.4 c o Use a more precise nondimensionalization that depends on (x,y)
16     c Added weighttype to the argument list so that I can geographically
17     c vary the nondimensionalization.
18     c gebbie@mit.edu, 18-Mar-2003
19     c
20 heimbach 1.2 c ==================================================================
21    
22     implicit none
23    
24     c == global variables ==
25    
26     #include "EEPARAMS.h"
27     #include "SIZE.h"
28     #include "PARAMS.h"
29     #include "GRID.h"
30    
31     #include "ctrl.h"
32    
33     #ifdef ALLOW_ECCO_OPTIMIZATION
34     #include "optim.h"
35     #endif
36    
37     c == routine arguments ==
38    
39     integer cunit
40     integer ivartype
41     character*( 80) fname
42     character* (5) masktype
43 heimbach 1.4 character*( 80) weighttype
44 heimbach 1.2 _RL weightfld( nr,nsx,nsy )
45     logical lxxadxx
46     integer mythid
47    
48     c == local variables ==
49    
50     #ifndef ALLOW_ECCO_OPTIMIZATION
51     integer optimcycle
52     #endif
53    
54     integer bi,bj
55     integer ip,jp
56     integer i,j,k
57     integer ii
58     integer il
59     integer irec
60     integer itlo,ithi
61     integer jtlo,jthi
62     integer jmin,jmax
63     integer imin,imax
64    
65     integer cbuffindex
66    
67 heimbach 1.7 real*4 cbuff ( snx*nsx*npx*sny*nsy*npy )
68 heimbach 1.2 _RL globmsk ( snx,nsx,npx,sny,nsy,npy,nr )
69     _RL globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
70 heimbach 1.4 #ifdef CTRL_PACK_PRECISE
71     _RL weightfld3d( snx,nsx,npx,sny,nsy,npy,nr )
72     #endif
73    
74     character*(80) weightname
75 heimbach 1.2
76     c == external ==
77    
78     integer ilnblnk
79     external ilnblnk
80    
81     c == end of interface ==
82    
83     #ifndef ALLOW_ECCO_OPTIMIZATION
84     optimcycle = 0
85     #endif
86    
87     jtlo = 1
88     jthi = nsy
89     itlo = 1
90     ithi = nsx
91     jmin = 1
92     jmax = sny
93     imin = 1
94     imax = snx
95    
96     c Initialise temporary file
97     do k = 1,nr
98     do jp = 1,nPy
99     do bj = jtlo,jthi
100     do j = jmin,jmax
101     do ip = 1,nPx
102     do bi = itlo,ithi
103     do i = imin,imax
104     globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
105     globmsk (i,bi,ip,j,bj,jp,k) = 0. _d 0
106     enddo
107     enddo
108     enddo
109     enddo
110     enddo
111     enddo
112     enddo
113    
114     c-- Only the master thread will do I/O.
115     _BEGIN_MASTER( mythid )
116    
117 heimbach 1.4 #ifdef CTRL_PACK_PRECISE
118     il=ilnblnk( weighttype)
119     write(weightname(1:80),'(80a)') ' '
120     write(weightname(1:80),'(a)') weighttype(1:il)
121    
122     call MDSREADFIELD_3D_GL(
123     & weightname, ctrlprec, 'RL',
124     & Nr, weightfld3d, 1, mythid)
125     #endif
126    
127 heimbach 1.2 call MDSREADFIELD_3D_GL(
128     & masktype, ctrlprec, 'RL',
129     & Nr, globmsk, 1, mythid)
130    
131     do irec = 1, ncvarrecs(ivartype)
132    
133     call MDSREADFIELD_3D_GL( fname, ctrlprec, 'RL',
134     & Nr, globfld3d, irec, mythid)
135    
136     write(cunit) ncvarindex(ivartype)
137     write(cunit) 1
138     write(cunit) 1
139     do k = 1, nr
140     cbuffindex = 0
141     do jp = 1,nPy
142     do bj = jtlo,jthi
143     do j = jmin,jmax
144     do ip = 1,nPx
145     do bi = itlo,ithi
146     do i = imin,imax
147     if (globmsk(i,bi,ip,j,bj,jp,k) .ne. 0. ) then
148     cbuffindex = cbuffindex + 1
149     #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
150     if (lxxadxx) then
151     cbuff(cbuffindex) =
152     & globfld3d(i,bi,ip,j,bj,jp,k) *
153 heimbach 1.4 # ifdef CTRL_PACK_PRECISE
154     & sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
155     # else
156 heimbach 1.2 & sqrt(weightfld(k,bi,bj))
157 heimbach 1.4 # endif
158 heimbach 1.2 else
159     cbuff(cbuffindex) =
160     & globfld3d(i,bi,ip,j,bj,jp,k) /
161 heimbach 1.4 # ifdef CTRL_PACK_PRECISE
162     & sqrt(weightfld3d(i,bi,ip,j,bj,jp,k))
163     # else
164 heimbach 1.2 & sqrt(weightfld(k,bi,bj))
165 heimbach 1.4 # endif
166 heimbach 1.2 endif
167 heimbach 1.4 #else /* ALLOW_NONDIMENSIONAL_CONTROL_IO undef */
168 heimbach 1.2 cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
169 heimbach 1.4 #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
170 heimbach 1.2 endif
171     enddo
172     enddo
173     enddo
174     enddo
175     enddo
176     enddo
177     c --> check cbuffindex.
178     if ( cbuffindex .gt. 0) then
179     write(cunit) cbuffindex
180     write(cunit) k
181     write(cunit) (cbuff(ii), ii=1,cbuffindex)
182     endif
183     enddo
184     c
185     c -- end of irec loop --
186     enddo
187    
188     _END_MASTER( mythid )
189    
190     return
191     end
192    
  ViewVC Help
Powered by ViewVC 1.1.22