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

Diff of /MITgcm/pkg/ctrl/ctrl_set_unpack_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_unpack_yz(        subroutine ctrl_set_unpack_yz(
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_yz  c     SUBROUTINE ctrl_set_unpack_yz
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    ( nsx*npx*sny*nsy*npy )        _RL     cbuff    ( nsx*npx*sny*nsy*npy )
       _RL     globmskyz( nsx,npx,sny,nsy,npy,nr )  
72        _RL     globfldyz( nsx,npx,sny,nsy,npy,nr )        _RL     globfldyz( nsx,npx,sny,nsy,npy,nr )
73          _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
74          _RL     globmskyz( nsx,npx,sny,nsy,npy,nr,nobcs )
75    #ifdef CTRL_UNPACK_PRECISE
76          _RL   weightfldyz( nsx,npx,sny,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 ip = 1,nPx                    do ip = 1,nPx
126                       do bi = itlo,ithi                       do bi = itlo,ithi
127                          globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0                          globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0
128                          globmskyz(bi,ip,j,bj,jp,k) = 0. _d 0                          do iobcs=1,nobcs
129                               globmskyz(bi,ip,j,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
162             call MDSREADFIELD_YZ_GL(
163         &        masktype, ctrlprec, 'RL',
164         &        Nr, globmskyz(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_YZ_GL(
170         &       weightname, ctrlprec, 'RL',
171         &       Nr, weightfldyz(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 j = jmin,jmax
179                         do ip = 1,nPx
180                            do bi = itlo,ithi
181                               weightfldyz(bi,ip,j,bj,jp,k,iobcs) = wbaro
182                            enddo
183                         enddo
184                      enddo
185                   enddo
186                enddo
187             endif
188    #endif
189          enddo
190    
191          nrec_nl=int(ncvarrecs(ivartype)/snx)
192          do irec = 1, nrec_nl
193  cgg      do iobcs = 1, nobcs  cgg      do iobcs = 1, nobcs
 cgg      Iobcs has already been included in the calculation  
 cgg      of ncvarrecs.  
194  cgg      And now back-calculate what iobcs should be.  cgg      And now back-calculate what iobcs should be.
195            gg   = (irec-1)/nobcs           do i=1,snx
196            igg  = int(gg)              iobcs= mod((irec-1)*snx+i-1,nobcs)+1
           iobcs = irec - igg*nobcs  
197    
198           call MDSREADFIELD_YZ_GL(              read(cunit) filencvarindex(ivartype)
199       &        masktype, ctrlprec, 'RL',              if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
200       &        Nr, globmskyz, iobcs, mythid)       &           then
201                   print *, 'ctrl_set_unpack_yz: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 j = jmin,jmax
228                      do ip = 1,nPx
229                       do bi = itlo,ithi
230                        if ( globmskyz(bi,ip,j,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(weightfldyz(bi,ip,j,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 i 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 has been removed.
261    cgg     enddo
262    c     -- end of irec loop --
263          enddo
264    
265          do irec = nrec_nl*snx+1,ncvarrecs(ivartype)
266             iobcs= mod(irec-1,nobcs)+1
267    
268           read(cunit) filencvarindex(ivartype)           read(cunit) filencvarindex(ivartype)
269           if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))           if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
# Line 150  cgg      And now back-calculate what iob Line 275  cgg      And now back-calculate what iob
275           read(cunit) filej           read(cunit) filej
276           read(cunit) filei           read(cunit) filei
277           do k = 1, Nr           do k = 1, Nr
278              cbuffindex = nwetglobal(k,iobcs)              cbuffindex = nwetglobal(k,iobcs)
279              if ( cbuffindex .gt. 0 ) then              if ( cbuffindex .gt. 0 ) then
280                 read(cunit) filencbuffindex                 read(cunit) filencbuffindex
281                 if (filencbuffindex .NE. cbuffindex) then                 if (filencbuffindex .NE. cbuffindex) then
# Line 172  cgg      And now back-calculate what iob Line 297  cgg      And now back-calculate what iob
297                do j = jmin,jmax                do j = jmin,jmax
298                 do ip = 1,nPx                 do ip = 1,nPx
299                  do bi = itlo,ithi                  do bi = itlo,ithi
300                    if ( globmskyz(bi,ip,j,bj,jp,k) .ne. 0. ) then                    if ( globmskyz(bi,ip,j,bj,jp,k,iobcs) .ne. 0. ) then
301                       cbuffindex = cbuffindex + 1                       cbuffindex = cbuffindex + 1
302                       globfldyz(bi,ip,j,bj,jp,k) = cbuff(cbuffindex)                       globfldyz(bi,ip,j,bj,jp,k) = cbuff(cbuffindex)
303  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
304                       globfldyz(bi,ip,j,bj,jp,k) =                       globfldyz(bi,ip,j,bj,jp,k) =
305       &                    globfldyz(bi,ip,j,bj,jp,k)/       &                    globfldyz(bi,ip,j,bj,jp,k)/
306    # ifdef CTRL_UNPACK_PRECISE
307         &                    sqrt(weightfldyz(bi,ip,j,bj,jp,k,iobcs))
308    # else
309       &                    sqrt(weightfld(k,iobcs))       &                    sqrt(weightfld(k,iobcs))
310  #endif  # endif
311    #endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
312                    else                    else
313                       globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0                       globfldyz(bi,ip,j,bj,jp,k) = 0. _d 0
314                    endif                    endif
# Line 189  cgg      And now back-calculate what iob Line 318  cgg      And now back-calculate what iob
318               enddo               enddo
319              enddo              enddo
320  c  c
321    c     -- end of k loop
322           enddo           enddo
323                            
324           call MDSWRITEFIELD_YZ_GL( fname, ctrlprec, 'RL',           call MDSWRITEFIELD_YZ_GL( fname, ctrlprec, 'RL',
325       &                             Nr, globfldyz, irec,       &                             Nr, globfldyz, irec,
326       &                             optimcycle, mythid)       &                             optimcycle, mythid)
 cgg     &                             Nr, globfldyz, (irec-1)*nobcs+iobcs,  
 cgg     &                             optimcycle, mythid)  
327    
328  c     -- end of iobcs loop -- This loop has been removed.  c     -- end of iobcs loop -- This loop has been removed.
329  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