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

Diff of /MITgcm/pkg/ctrl/ctrl_set_pack_yz.F

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

revision 1.2 by heimbach, Sat Jul 13 02:47:32 2002 UTC revision 1.3 by heimbach, Tue Jun 24 16:07:07 2003 UTC
# Line 3  Line 3 
3    
4    
5        subroutine ctrl_set_pack_yz(        subroutine ctrl_set_pack_yz(
6       &     cunit, ivartype, fname, masktype,       &     cunit, ivartype, fname, masktype, weighttype,
7       &     weightfld, lxxadxx, mythid)       &     weightfld, lxxadxx, mythid)
8    
9  c     ==================================================================  c     ==================================================================
# Line 13  c Line 13  c
13  c     o Compress the control vector such that only ocean points are  c     o Compress the control vector such that only ocean points are
14  c       written to file.  c       written to file.
15  c  c
16    c     o Open boundary packing added :
17    c          gebbie@mit.edu, 18-Mar-2003
18    c
19    c     changed: heimbach@mit.edu 17-Jun-2003
20    c              merged Armin's changes to replace write of
21    c              nr * globfld2d by 1 * globfld3d
22    c              (ad hoc fix to speed up global I/O)
23    c
24  c     ==================================================================  c     ==================================================================
25    
26        implicit none        implicit none
# Line 37  c     == routine arguments == Line 45  c     == routine arguments ==
45        integer ivartype        integer ivartype
46        character*( 80) fname        character*( 80) fname
47        character*(  9) masktype        character*(  9) masktype
48          character*( 80) weighttype
49        _RL     weightfld( nr,nobcs )        _RL     weightfld( nr,nobcs )
50        logical lxxadxx        logical lxxadxx
51        integer mythid        integer mythid
# Line 52  c     == local variables == Line 61  c     == local variables ==
61        integer i,j,k        integer i,j,k
62        integer ii        integer ii
63        integer il        integer il
64        integer irec,iobcs        integer irec,iobcs,nrec_nl
65        integer itlo,ithi        integer itlo,ithi
66        integer jtlo,jthi        integer jtlo,jthi
67        integer jmin,jmax        integer jmin,jmax
# Line 62  c     == local variables == Line 71  c     == local variables ==
71  cgg(  cgg(
72        integer igg        integer igg
73        _RL     gg        _RL     gg
74          character*(80) weightname
75  cgg)  cgg)
76        _RL     cbuff      ( nsx*npx*sny*nsy*npy )        _RL     cbuff      ( nsx*npx*sny*nsy*npy )
       _RL     globmskyz  ( nsx,npx,sny,nsy,npy,nr )  
77        _RL     globfldyz  ( nsx,npx,sny,nsy,npy,nr )        _RL     globfldyz  ( nsx,npx,sny,nsy,npy,nr )
78          _RL     globfld3d  ( snx,nsx,npx,sny,nsy,npy,nr )
79          _RL     globmskyz  ( nsx,npx,sny,nsy,npy,nr,nobcs )
80    #ifdef CTRL_PACK_PRECISE
81          _RL     weightfldyz( nsx,npx,sny,nsy,npy,nr,nobcs )
82    #endif
83    
84  c     == external ==  c     == external ==
85    
# Line 95  c     Initialise temporary file Line 109  c     Initialise temporary file
109                    do ip = 1,nPx                    do ip = 1,nPx
110                       do bi = itlo,ithi                       do bi = itlo,ithi
111                          globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0                          globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0
112                          globmskyz(bi,ip,j,bj,jp,k) = 0. _d 0                          do iobcs=1,nobcs
113                               globmskyz(bi,ip,j,bj,jp,k,iobcs) = 0. _d 0
114                            enddo
115                         enddo
116                      enddo
117                   enddo
118                enddo
119             enddo
120          enddo
121    c     Initialise temporary file
122          do k = 1,nr
123             do jp = 1,nPy
124                do bj = jtlo,jthi
125                   do j = jmin,jmax
126                      do ip = 1,nPx
127                         do bi = itlo,ithi
128                            do i = imin,imax
129                               globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
130                            enddo
131                       enddo                       enddo
132                    enddo                    enddo
133                 enddo                 enddo
# Line 106  c     Initialise temporary file Line 138  c     Initialise temporary file
138  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
139        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
140    
141        do irec = 1, ncvarrecs(ivartype)        do iobcs=1,nobcs
142             call MDSREADFIELD_YZ_GL(
143         &        masktype, ctrlprec, 'RL',
144         &        Nr, globmskyz(1,1,1,1,1,1,iobcs), iobcs,mythid)
145    #ifdef CTRL_PACK_PRECISE
146             il=ilnblnk( weighttype)
147             write(weightname(1:80),'(80a)') ' '
148             write(weightname(1:80),'(a)') weighttype(1:il)
149             call MDSREADFIELD_YZ_GL(
150         &       weightname, ctrlprec, 'RL',
151         &       Nr, weightfldyz(1,1,1,1,1,1,iobcs), iobcs, mythid)
152    CGG   One special exception: barotropic velocity should be nondimensionalized
153    cgg   differently. Probably introduce new variable.
154             if (iobcs .eq. 3 .or. iobcs .eq. 4) then
155                k = 1
156                do jp = 1,nPy
157                   do bj = jtlo,jthi
158                      do j = jmin,jmax
159                         do ip = 1,nPx
160                            do bi = itlo,ithi
161                               weightfldyz(bi,ip,j,bj,jp,k,iobcs) = wbaro
162                            enddo
163                         enddo
164                      enddo
165                   enddo
166                enddo
167             endif
168    #endif
169          enddo
170    
171          nrec_nl=int(ncvarrecs(ivartype)/snx)
172          do irec = 1, nrec_nl
173  cgg       do iobcs = 1, nobcs  cgg       do iobcs = 1, nobcs
174  cgg    Need to solve for what iobcs would have been.  cgg    Need to solve for what iobcs would have been.
           gg   = (irec-1)/nobcs  
           igg  = int(gg)  
           iobcs= irec - igg*nobcs  
175    
176           call MDSREADFIELD_YZ_GL(           call MDSREADFIELD_3D_GL( fname, ctrlprec, 'RL',
177       &        masktype, ctrlprec, 'RL',       &        nr, globfld3D, irec, mythid)
178       &        Nr, globmskyz, iobcs, mythid)  
179             do i=1,snx
180                iobcs= mod((irec-1)*snx+i-1,nobcs)+1
181    
182    CGG   One special exception: barotropic velocity should be nondimensionalized
183    cgg   differently. Probably introduce new variable.
184                if (iobcs .eq. 3 .or. iobcs .eq. 4) then
185                   k = 1
186                   do jp = 1,nPy
187                      do bj = jtlo,jthi
188                         do j = jmin,jmax
189                            do ip = 1,nPx
190                               do bi = itlo,ithi
191    #ifdef NO_CONTROL_BAROTROPIC_VELOCITY
192                                  if (.not. lxxadxx) then
193    cgg    Get rid of any sensitivity to barotropic velocity.
194                                     globfld3d(i,bi,ip,j,bj,jp,k) = 0.
195                                  endif
196    #endif
197                               enddo
198                            enddo
199                         enddo
200                      enddo
201                   enddo
202                endif
203    
204                write(cunit) ncvarindex(ivartype)
205                write(cunit) 1
206                write(cunit) 1
207                do k = 1,nr
208                 cbuffindex = 0
209                 do jp = 1,nPy
210                  do bj = jtlo,jthi
211                   do ip = 1,nPx
212                    do bi = itlo,ithi
213                     do j = jmin,jmax
214                      if (globmskyz(bi,ip,j,bj,jp,k,iobcs)  .ne. 0. ) then
215                         cbuffindex = cbuffindex + 1
216    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
217                         if (lxxadxx) then
218                            cbuff(cbuffindex) =
219         &                       globfld3d(i,bi,ip,j,bj,jp,k) *
220    #ifdef CTRL_PACK_PRECISE
221         &                       sqrt(weightfldyz(bi,ip,j,bj,jp,k,iobcs))
222    #else
223         &                       sqrt(weightfld(k,iobcs))
224    #endif
225                         else
226                            cbuff(cbuffindex) =
227         &                       globfld3d(i,bi,ip,j,bj,jp,k) /
228    #ifdef CTRL_PACK_PRECISE
229         &                       sqrt(weightfldyz(bi,ip,j,bj,jp,k,iobcs))
230    #else
231         &                       sqrt(weightfld(k,iobcs))
232    #endif
233                         endif
234    #else /* ALLOW_NONDIMENSIONAL_CONTROL_IO undef */
235                         cbuff(cbuffindex) = globfld3d(i,bi,ip,j,bj,jp,k)
236    #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
237                      endif
238                     enddo
239                    enddo
240                   enddo
241                  enddo
242                 enddo
243    c           --> check cbuffindex.
244                 if ( cbuffindex .gt. 0) then
245                    write(cunit) cbuffindex
246                    write(cunit) k
247                    write(cunit) (cbuff(ii), ii=1,cbuffindex)
248                 endif
249    c
250    c     -- end of k loop --
251                enddo
252    c     -- end of iobcs loop --
253    cgg       enddo
254    c     -- end of i loop --
255             enddo
256    c     -- end of irec loop --
257          enddo
258    
259          do irec = nrec_nl*snx+1, ncvarrecs(ivartype)
260    cgg       do iobcs = 1, nobcs
261    cgg    Need to solve for what iobcs would have been.
262             iobcs= mod(irec-1,nobcs)+1
263    
264           call MDSREADFIELD_YZ_GL( fname, ctrlprec, 'RL',           call MDSREADFIELD_YZ_GL( fname, ctrlprec, 'RL',
265       &        nr, globfldyz, irec, mythid)       &        nr, globfldyz, irec, mythid)
266    
267    CGG   One special exception: barotropic velocity should be nondimensionalized
268    cgg   differently. Probably introduce new variable.
269             if (iobcs .eq. 3 .or. iobcs .eq. 4) then
270                k = 1
271                do jp = 1,nPy
272                   do bj = jtlo,jthi
273                      do j = jmin,jmax
274                         do ip = 1,nPx
275                            do bi = itlo,ithi
276    #ifdef NO_CONTROL_BAROTROPIC_VELOCITY
277                               if (.not. lxxadxx) then
278    cgg    Get rid of any sensitivity to barotropic velocity.
279                                  globfldyz(bi,ip,j,bj,jp,k) = 0.
280                               endif
281    #endif
282                            enddo
283                         enddo
284                      enddo
285                   enddo
286                enddo
287             endif
288    
289           write(cunit) ncvarindex(ivartype)           write(cunit) ncvarindex(ivartype)
290           write(cunit) 1           write(cunit) 1
291           write(cunit) 1           write(cunit) 1
# Line 131  cgg    Need to solve for what iobcs woul Line 296  cgg    Need to solve for what iobcs woul
296                do ip = 1,nPx                do ip = 1,nPx
297                 do bi = itlo,ithi                 do bi = itlo,ithi
298                  do j = jmin,jmax                  do j = jmin,jmax
299                   if (globmskyz(bi,ip,j,bj,jp,k)  .ne. 0. ) then                   if (globmskyz(bi,ip,j,bj,jp,k,iobcs)  .ne. 0. ) then
300                       cbuffindex = cbuffindex + 1                       cbuffindex = cbuffindex + 1
301  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
302                       if (lxxadxx) then                       if (lxxadxx) then
303                          cbuff(cbuffindex) =                          cbuff(cbuffindex) =
304       &                       globfldyz(bi,ip,j,bj,jp,k) *       &                       globfldyz(bi,ip,j,bj,jp,k) *
305    #ifdef CTRL_PACK_PRECISE
306         &                       sqrt(weightfldyz(bi,ip,j,bj,jp,k,iobcs))
307    #else
308       &                       sqrt(weightfld(k,iobcs))       &                       sqrt(weightfld(k,iobcs))
309    #endif
310                       else                       else
311                          cbuff(cbuffindex) =                          cbuff(cbuffindex) =
312       &                       globfldyz(bi,ip,j,bj,jp,k) /       &                       globfldyz(bi,ip,j,bj,jp,k) /
313    #ifdef CTRL_PACK_PRECISE
314         &                       sqrt(weightfldyz(bi,ip,j,bj,jp,k,iobcs))
315    #else
316       &                       sqrt(weightfld(k,iobcs))       &                       sqrt(weightfld(k,iobcs))
317    #endif
318                       endif                       endif
319  #else  #else /* ALLOW_NONDIMENSIONAL_CONTROL_IO undef */
320                       cbuff(cbuffindex) = globfldyz(bi,ip,j,bj,jp,k)                       cbuff(cbuffindex) = globfldyz(bi,ip,j,bj,jp,k)
321  #endif  #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
322                   endif                   endif
323                  enddo                  enddo
324                 enddo                 enddo
# Line 158  c           --> check cbuffindex. Line 331  c           --> check cbuffindex.
331                 write(cunit) k                 write(cunit) k
332                 write(cunit) (cbuff(ii), ii=1,cbuffindex)                 write(cunit) (cbuff(ii), ii=1,cbuffindex)
333              endif              endif
          enddo  
334  c  c
335    c     -- end of k loop --
336             enddo
337  c     -- end of iobcs loop --  c     -- end of iobcs loop --
338  cgg       enddo  cgg       enddo
339  c     -- end of irec loop --  c     -- end of irec loop --
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3
  ViewVC Help
Powered by ViewVC 1.1.22