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

Diff of /MITgcm/pkg/ctrl/ctrl_set_unpack_xz.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_unpack_xz(        subroutine ctrl_set_unpack_xz(
6       &     cunit, ivartype, fname, masktype,       &     cunit, ivartype, fname, masktype, weighttype,
7       &     weightfld, nwetglobal, mythid)       &     weightfld, nwetglobal, mythid)
8    
9  c     ==================================================================  c     ==================================================================
10  c     SUBROUTINE ctrl_set_unpack_xz  c     SUBROUTINE ctrl_set_unpack_xz
11  c     ==================================================================  c     ==================================================================
12  c  c
13  c     o Unpack the control vector such that the land points are filled  c     o Unpack the control vector such that land points are filled in.
14  c       in.  c
15    c     o Open boundary packing added :
16    c          gebbie@mit.edu, 18-Mar-2003
17    c
18    c     changed: heimbach@mit.edu 17-Jun-2003
19    c              merged Armin's changes to replace write of
20    c              nr * globfld2d by 1 * globfld3d
21    c              (ad hoc fix to speed up global I/O)
22  c  c
23  c     ==================================================================  c     ==================================================================
24    
# Line 37  c     == routine arguments == Line 44  c     == routine arguments ==
44        integer ivartype        integer ivartype
45        character*( 80)   fname        character*( 80)   fname
46        character*  (9) masktype        character*  (9) masktype
47          character*( 80) weighttype
48        _RL     weightfld( nr,nobcs )        _RL     weightfld( nr,nobcs )
49        integer nwetglobal(nr,nobcs)        integer nwetglobal(nr,nobcs)
50        integer mythid        integer mythid
# Line 52  c     == local variables == Line 60  c     == local variables ==
60        integer i,j,k        integer i,j,k
61        integer ii        integer ii
62        integer il        integer il
63        integer irec,iobcs        integer irec,iobcs,nrec_nl
64        integer itlo,ithi        integer itlo,ithi
65        integer jtlo,jthi        integer jtlo,jthi
66        integer jmin,jmax        integer jmin,jmax
# Line 61  c     == local variables == Line 69  c     == local variables ==
69        integer cbuffindex        integer cbuffindex
70    
71        _RL     cbuff    ( snx*nsx*npx*nsy*npy )        _RL     cbuff    ( snx*nsx*npx*nsy*npy )
       _RL     globmskxz( snx,nsx,npx,nsy,npy,nr )  
72        _RL     globfldxz( snx,nsx,npx,nsy,npy,nr )        _RL     globfldxz( snx,nsx,npx,nsy,npy,nr )
73          _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
74          _RL     globmskxz( snx,nsx,npx,nsy,npy,nr,nobcs )
75    #ifdef CTRL_UNPACK_PRECISE
76          _RL   weightfldxz( snx,nsx,npx,nsy,npy,nr,nobcs )
77    #endif
78    
79        integer        filenvartype        integer        filenvartype
80        integer        filenvarlength        integer        filenvarlength
# Line 86  c     == local variables == Line 98  c     == local variables ==
98  cgg(  cgg(
99        integer igg        integer igg
100        _RL     gg        _RL     gg
101          character*(80) weightname
102  cgg)  cgg)
103    
104  c     == external ==  c     == external ==
# Line 112  c     Initialise temporary file Line 125  c     Initialise temporary file
125                    do bi = itlo,ithi                    do bi = itlo,ithi
126                       do i = imin,imax                       do i = imin,imax
127                          globfldxz(i,bi,ip,bj,jp,k) = 0. _d 0                          globfldxz(i,bi,ip,bj,jp,k) = 0. _d 0
128                          globmskxz(i,bi,ip,bj,jp,k) = 0. _d 0                          do iobcs=1,nobcs
129                               globmskxz(i,bi,ip,bj,jp,k,iobcs) = 0. _d 0
130                            enddo
131                         enddo
132                      enddo
133                   enddo
134                enddo
135             enddo
136          enddo
137    c     Initialise temporary file
138          do k = 1,nr
139             do jp = 1,nPy
140                do bj = jtlo,jthi
141                   do j = jmin,jmax
142                      do ip = 1,nPx
143                         do bi = itlo,ithi
144                            do i = imin,imax
145                               globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
146                            enddo
147                       enddo                       enddo
148                    enddo                    enddo
149                 enddo                 enddo
# Line 127  c     Initialise temporary file Line 158  c     Initialise temporary file
158  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
159        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
160    
161        do irec = 1, ncvarrecs(ivartype)        do iobcs=1,nobcs
 cgg       do iobcs = 1, nobcs  
 cgg      Iobcs has already been included in the calculation  
 cgg      of ncvarrecs.  
 cgg      And now back-calculate what iobcs should be.  
           gg   = (irec-1)/nobcs  
           igg  = int(gg)  
           iobcs = irec - igg*nobcs  
   
162           call MDSREADFIELD_XZ_GL(           call MDSREADFIELD_XZ_GL(
163       &        masktype, ctrlprec, 'RL',       &        masktype, ctrlprec, 'RL',
164       &        Nr, globmskxz, iobcs, mythid)       &        Nr, globmskxz(1,1,1,1,1,1,iobcs), iobcs,mythid)
165    #ifdef CTRL_UNPACK_PRECISE
166             il=ilnblnk( weighttype)
167             write(weightname(1:80),'(80a)') ' '
168             write(weightname(1:80),'(a)') weighttype(1:il)
169             call MDSREADFIELD_XZ_GL(
170         &        weightname, ctrlprec, 'RL',
171         &        Nr, weightfldxz(1,1,1,1,1,1,iobcs), iobcs, mythid)
172    CGG   One special exception: barotropic velocity should be nondimensionalized
173    cgg   differently. Probably introduce new variable.
174             if (iobcs .eq. 3 .or. iobcs .eq. 4) then
175                k = 1
176                do jp = 1,nPy
177                   do bj = jtlo,jthi
178                      do ip = 1,nPx
179                         do bi = itlo,ithi
180                            do i = imin,imax
181                               weightfldxz(i,bi,ip,bj,jp,k,iobcs) = wbaro
182                            enddo
183                         enddo
184                      enddo
185                   enddo
186                enddo
187             endif
188    #endif /* CTRL_UNPACK_PRECISE */
189          enddo
190    
191          nrec_nl=int(ncvarrecs(ivartype)/sny)
192          do irec = 1, nrec_nl
193    cgg       do iobcs = 1, nobcs
194    cgg       And now back-calculate what iobcs should be.
195             do j=1,sny
196                iobcs= mod((irec-1)*sny+j-1,nobcs)+1
197        
198                read(cunit) filencvarindex(ivartype)
199                if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
200         &           then
201                   print *, 'ctrl-set_unpack:xz:WARNING: wrong ncvarindex ',
202         &              filencvarindex(ivartype), ncvarindex(ivartype)
203                   STOP 'in S/R ctrl_unpack'
204                endif
205                read(cunit) filej
206                read(cunit) filei
207                do k = 1, Nr
208                   cbuffindex = nwetglobal(k,iobcs)
209                   if ( cbuffindex .gt. 0 ) then
210                      read(cunit) filencbuffindex
211                      if (filencbuffindex .NE. cbuffindex) then
212                         print *, 'WARNING: wrong cbuffindex ',
213         &                    filencbuffindex, cbuffindex
214                         STOP 'in S/R ctrl_unpack'
215                      endif
216                      read(cunit) filek
217                      if (filek .NE. k) then
218                         print *, 'WARNING: wrong k ',
219         &                    filek, k
220                         STOP 'in S/R ctrl_unpack'
221                      endif
222                      read(cunit) (cbuff(ii), ii=1,cbuffindex)
223                   endif
224                   cbuffindex = 0
225                   do jp = 1,nPy
226                    do bj = jtlo,jthi
227                     do ip = 1,nPx
228                      do bi = itlo,ithi
229                       do i = imin,imax
230                        if ( globmskxz(i,bi,ip,bj,jp,k,iobcs) .ne. 0. ) then
231                           cbuffindex = cbuffindex + 1
232                           globfld3d(i,bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
233    #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
234                           globfld3d(i,bi,ip,j,bj,jp,k) =
235         &                      globfld3d(i,bi,ip,j,bj,jp,k)/
236    # ifdef CTRL_UNPACK_PRECISE
237         &                      sqrt(weightfldxz(i,bi,ip,bj,jp,k,iobcs))
238    # else
239         &                      sqrt(weightfld(k,iobcs))
240    # endif
241    #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
242                        else
243                           globfld3d(i,bi,ip,j,bj,jp,k) = 0. _d 0
244                        endif
245                       enddo
246                      enddo
247                     enddo
248                    enddo
249                   enddo
250    c
251    c     -- end of k loop --
252             enddo
253    c     -- end of j loop --
254             enddo
255                
256             call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',
257         &                             Nr, globfld3d, irec,
258         &                             optimcycle, mythid)
259    
260    c     -- end of iobcs loop -- This loop removed. 3-28-02.
261    cgg       enddo
262    c     -- end of irec loop --
263          enddo
264    
265          do irec = nrec_nl*sny+1, ncvarrecs(ivartype)
266    cgg       do iobcs = 1, nobcs
267    cgg       And now back-calculate what iobcs should be.
268             iobcs= mod(irec-1,nobcs)+1
269    
270           read(cunit) filencvarindex(ivartype)           read(cunit) filencvarindex(ivartype)
271           if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))           if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
# Line 172  cgg      And now back-calculate what iob Line 299  cgg      And now back-calculate what iob
299                do ip = 1,nPx                do ip = 1,nPx
300                 do bi = itlo,ithi                 do bi = itlo,ithi
301                  do i = imin,imax                  do i = imin,imax
302                    if ( globmskxz(i,bi,ip,bj,jp,k) .ne. 0. ) then                    if ( globmskxz(i,bi,ip,bj,jp,k,iobcs) .ne. 0. ) then
303                       cbuffindex = cbuffindex + 1                       cbuffindex = cbuffindex + 1
304                       globfldxz(i,bi,ip,bj,jp,k) = cbuff(cbuffindex)                       globfldxz(i,bi,ip,bj,jp,k) = cbuff(cbuffindex)
305  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
306                       globfldxz(i,bi,ip,bj,jp,k) =                       globfldxz(i,bi,ip,bj,jp,k) =
307       &                    globfldxz(i,bi,ip,bj,jp,k)/       &                    globfldxz(i,bi,ip,bj,jp,k)/
308    # ifdef CTRL_UNPACK_PRECISE
309         &                    sqrt(weightfldxz(i,bi,ip,bj,jp,k,iobcs))
310    # else
311       &                    sqrt(weightfld(k,iobcs))       &                    sqrt(weightfld(k,iobcs))
312  #endif  # endif
313    #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
314                    else                    else
315                       globfldxz(i,bi,ip,bj,jp,k) = 0. _d 0                       globfldxz(i,bi,ip,bj,jp,k) = 0. _d 0
316                    endif                    endif
# Line 189  cgg      And now back-calculate what iob Line 320  cgg      And now back-calculate what iob
320               enddo               enddo
321              enddo              enddo
322  c  c
323    c     -- end of k loop --
324           enddo           enddo
325                            
326           call MDSWRITEFIELD_XZ_GL( fname, ctrlprec, 'RL',           call MDSWRITEFIELD_XZ_GL( fname, ctrlprec, 'RL',
327       &                             Nr, globfldxz, irec,       &                             Nr, globfldxz, irec,
328       &                             optimcycle, mythid)       &                             optimcycle, mythid)
 cgg     &                             Nr, globfldxz, (irec-1)*nobcs+iobcs,  
 cgg     &                             optimcycle, mythid)  
329    
330  c     -- end of iobcs loop -- This loop removed. 3-28-02.  c     -- end of iobcs loop -- This loop removed. 3-28-02.
331  cgg       enddo  cgg       enddo
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3
  ViewVC Help
Powered by ViewVC 1.1.22