/[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.9 by heimbach, Tue Nov 16 05:42:12 2004 UTC revision 1.15 by jmc, Mon Mar 22 02:16:43 2010 UTC
# Line 1  Line 1 
1    C $Header$
2    C $Name$
3    
4  #include "CTRL_CPPOPTIONS.h"  #include "CTRL_CPPOPTIONS.h"
5    
# Line 15  c     o Open boundary packing added : Line 17  c     o Open boundary packing added :
17  c          gebbie@mit.edu, 18-Mar-2003  c          gebbie@mit.edu, 18-Mar-2003
18  c  c
19  c     changed: heimbach@mit.edu 17-Jun-2003  c     changed: heimbach@mit.edu 17-Jun-2003
20  c              merged Armin's changes to replace write of  c              merged changes from Armin to replace write of
21  c              nr * globfld2d by 1 * globfld3d  c              nr * globfld2d by 1 * globfld3d
22  c              (ad hoc fix to speed up global I/O)  c              (ad hoc fix to speed up global I/O)
23  c  c
# Line 44  c     == routine arguments == Line 46  c     == routine arguments ==
46        integer nwetglobal(nr,nobcs)        integer nwetglobal(nr,nobcs)
47        integer mythid        integer mythid
48    
49    #ifndef EXCLUDE_CTRL_PACK
50  c     == local variables ==  c     == local variables ==
51    
52          logical lxxadxx
53    
54        integer bi,bj        integer bi,bj
55        integer ip,jp        integer ip,jp
56        integer i,j,k        integer i,j,k
# Line 59  c     == local variables == Line 64  c     == local variables ==
64    
65        integer cbuffindex        integer cbuffindex
66    
67        real*4     cbuff    ( snx*nsx*npx*nsy*npy )        real*4 cbuff      ( snx*nsx*npx*nsy*npy )
68          real*4 globfldtmp2( snx,nsx,npx,nsy,npy )
69          real*4 globfldtmp3( snx,nsx,npx,nsy,npy )
70        _RL     globfldxz( snx,nsx,npx,nsy,npy,nr )        _RL     globfldxz( snx,nsx,npx,nsy,npy,nr )
71        _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )        _RL     globfld3d( snx,nsx,npx,sny,nsy,npy,nr )
72        _RL     globmskxz( snx,nsx,npx,nsy,npy,nr,nobcs )        _RL     globmskxz( snx,nsx,npx,nsy,npy,nr,nobcs )
# Line 68  c     == local variables == Line 75  c     == local variables ==
75  #endif  #endif
76    
77  cgg(  cgg(
78          integer reclen, irectrue
79          integer cunit2, cunit3
80        integer igg        integer igg
81        _RL     gg        _RL     gg
82        character*(80) weightname        character*(80) weightname
83          character*(80) cfile2, cfile3
84  cgg)  cgg)
85    
86  c     == external ==  c     == external ==
# Line 89  cc     == end of interface == Line 99  cc     == end of interface ==
99        imin = 1        imin = 1
100        imax = snx        imax = snx
101    
102          lxxadxx = .TRUE.
103    
104  c     Initialise temporary file  c     Initialise temporary file
105        do k = 1,nr        do k = 1,nr
106           do jp = 1,nPy           do jp = 1,nPy
# Line 96  c     Initialise temporary file Line 108  c     Initialise temporary file
108                 do ip = 1,nPx                 do ip = 1,nPx
109                    do bi = itlo,ithi                    do bi = itlo,ithi
110                       do i = imin,imax                       do i = imin,imax
111                          globfldxz(i,bi,ip,bj,jp,k) = 0. _d 0                          globfldxz  (i,bi,ip,bj,jp,k) = 0. _d 0
112                            globfldtmp2(i,bi,ip,bj,jp)   = 0.
113                            globfldtmp3(i,bi,ip,bj,jp)   = 0.
114                          do iobcs=1,nobcs                          do iobcs=1,nobcs
115                             globmskxz(i,bi,ip,bj,jp,k,iobcs) = 0. _d 0                             globmskxz(i,bi,ip,bj,jp,k,iobcs) = 0. _d 0
116                          enddo                          enddo
# Line 126  c     Initialise temporary file Line 140  c     Initialise temporary file
140  c--   Only the master thread will do I/O.  c--   Only the master thread will do I/O.
141        _BEGIN_MASTER( mythid )        _BEGIN_MASTER( mythid )
142    
143          if ( doPackDiag ) then
144             write(cfile2(1:80),'(80a)') ' '
145             write(cfile3(1:80),'(80a)') ' '
146             if ( lxxadxx ) then
147                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
148         &           'diag_unpack_nondim_ctrl_',
149         &           ivartype, '_', optimcycle, '.bin'
150                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
151         &           'diag_unpack_dimens_ctrl_',
152         &           ivartype, '_', optimcycle, '.bin'
153             else
154                write(cfile2(1:80),'(a,I2.2,a,I4.4,a)')
155         &           'diag_unpack_nondim_grad_',
156         &           ivartype, '_', optimcycle, '.bin'
157                write(cfile3(1:80),'(a,I2.2,a,I4.4,a)')
158         &           'diag_unpack_dimens_grad_',
159         &           ivartype, '_', optimcycle, '.bin'
160             endif
161    
162             reclen = snx*nsx*npx*nsy*npy*4
163             call mdsfindunit( cunit2, mythid )
164             open( cunit2, file=cfile2, status='unknown',
165         &        access='direct', recl=reclen )
166             call mdsfindunit( cunit3, mythid )
167             open( cunit3, file=cfile3, status='unknown',
168         &        access='direct', recl=reclen )
169          endif
170    
171        do iobcs=1,nobcs        do iobcs=1,nobcs
172           call MDSREADFIELD_XZ_GL(           call MDSREADFIELD_XZ_GL(
173       &        masktype, ctrlprec, 'RL',       &        masktype, ctrlprec, 'RL',
174       &        Nr, globmskxz(1,1,1,1,1,1,iobcs), iobcs,mythid)       &        Nr, globmskxz(1,1,1,1,1,1,iobcs), iobcs,mythid)
175  #ifdef CTRL_UNPACK_PRECISE  #ifdef CTRL_UNPACK_PRECISE
# Line 146  cgg   differently. Probably introduce ne Line 188  cgg   differently. Probably introduce ne
188                    do ip = 1,nPx                    do ip = 1,nPx
189                       do bi = itlo,ithi                       do bi = itlo,ithi
190                          do i = imin,imax                          do i = imin,imax
191                             weightfldxz(i,bi,ip,bj,jp,k,iobcs) = wbaro  cph                           weightfldxz(i,bi,ip,bj,jp,k,iobcs) = wbaro
192                          enddo                          enddo
193                       enddo                       enddo
194                    enddo                    enddo
# Line 156  cgg   differently. Probably introduce ne Line 198  cgg   differently. Probably introduce ne
198  #endif /* CTRL_UNPACK_PRECISE */  #endif /* CTRL_UNPACK_PRECISE */
199        enddo        enddo
200    
201        nrec_nl=int(ncvarrecs(ivartype)/sny)        if ( useSingleCPUio ) then
202    C     MDSWRITEFIELD_XZ_GL does not know about useSingleCPUio, so the faster
203    C     method that works for .not.useSingleCPUio cannot be used
204           nrec_nl = 0
205          else
206           nrec_nl = int(ncvarrecs(ivartype)/Ny)
207          endif
208        do irec = 1, nrec_nl        do irec = 1, nrec_nl
209  cgg       do iobcs = 1, nobcs  cgg       do iobcs = 1, nobcs
210  cgg       And now back-calculate what iobcs should be.  cgg       And now back-calculate what iobcs should be.
211           do j=1,sny           do j=1,sny
212              iobcs= mod((irec-1)*sny+j-1,nobcs)+1              iobcs= mod((irec-1)*sny+j-1,nobcs)+1
213        
214              read(cunit) filencvarindex(ivartype)              read(cunit) filencvarindex(ivartype)
215              if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))              if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
216       &           then       &           then
# Line 173  cgg       And now back-calculate what io Line 221  cgg       And now back-calculate what io
221              read(cunit) filej              read(cunit) filej
222              read(cunit) filei              read(cunit) filei
223              do k = 1, Nr              do k = 1, Nr
224                   irectrue = (irec-1)*nobcs*nr + (iobcs-1)*nr + k
225                 cbuffindex = nwetglobal(k,iobcs)                 cbuffindex = nwetglobal(k,iobcs)
226                 if ( cbuffindex .gt. 0 ) then                 if ( cbuffindex .gt. 0 ) then
227                    read(cunit) filencbuffindex                    read(cunit) filencbuffindex
# Line 189  cgg       And now back-calculate what io Line 238  cgg       And now back-calculate what io
238                    endif                    endif
239                    read(cunit) (cbuff(ii), ii=1,cbuffindex)                    read(cunit) (cbuff(ii), ii=1,cbuffindex)
240                 endif                 endif
241    
242                 cbuffindex = 0                 cbuffindex = 0
243                 jj=mod((j-1)*nr+k-1,sny)+1                 jj=mod((j-1)*nr+k-1,sny)+1
244                 kk=int((j-1)*nr+k-1)/sny+1                 kk=int((j-1)*nr+k-1)/sny+1
# Line 199  cgg       And now back-calculate what io Line 249  cgg       And now back-calculate what io
249                     do i = imin,imax                     do i = imin,imax
250                      if ( globmskxz(i,bi,ip,bj,jp,k,iobcs) .ne. 0. ) then                      if ( globmskxz(i,bi,ip,bj,jp,k,iobcs) .ne. 0. ) then
251                         cbuffindex = cbuffindex + 1                         cbuffindex = cbuffindex + 1
252                         globfld3d(i,bi,ip,jj,bj,jp,kk) =                         globfld3d(i,bi,ip,jj,bj,jp,kk) =
253         &                      cbuff(cbuffindex)
254    cph(
255                           globfldtmp2(i,bi,ip,bj,jp) =
256       &                      cbuff(cbuffindex)       &                      cbuff(cbuffindex)
257    cph)
258  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
259                         globfld3d(i,bi,ip,jj,bj,jp,kk) =                         globfld3d(i,bi,ip,jj,bj,jp,kk) =
260       &                      globfld3d(i,bi,ip,jj,bj,jp,kk)/       &                      globfld3d(i,bi,ip,jj,bj,jp,kk)/
261  # ifdef CTRL_UNPACK_PRECISE  # ifdef CTRL_UNPACK_PRECISE
262       &                      sqrt(weightfldxz(i,bi,ip,bj,jp,k,iobcs))       &                      sqrt(weightfldxz(i,bi,ip,bj,jp,k,iobcs))
# Line 213  cgg       And now back-calculate what io Line 267  cgg       And now back-calculate what io
267                      else                      else
268                         globfld3d(i,bi,ip,jj,bj,jp,kk) = 0. _d 0                         globfld3d(i,bi,ip,jj,bj,jp,kk) = 0. _d 0
269                      endif                      endif
270    cph(
271                        globfldtmp3(i,bi,ip,bj,jp) =
272         &                   globfld3d(i,bi,ip,jj,bj,jp,kk)
273    cph)
274                     enddo                     enddo
275                    enddo                    enddo
276                   enddo                   enddo
277                  enddo                  enddo
278                 enddo                 enddo
279  c  c
280                   if ( doPackDiag ) then
281                      write(cunit2,rec=irectrue) globfldtmp2
282                      write(cunit3,rec=irectrue) globfldtmp3
283                   endif
284    c
285  c     -- end of k loop --  c     -- end of k loop --
286           enddo           enddo
287  c     -- end of j loop --  c     -- end of j loop --
288           enddo           enddo
289                
290           call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',           call MDSWRITEFIELD_3D_GL( fname, ctrlprec, 'RL',
291       &                             Nr, globfld3d, irec,       &                             Nr, globfld3d, irec,
292       &                             optimcycle, mythid)       &                             optimcycle, mythid)
# Line 233  cgg       enddo Line 296  cgg       enddo
296  c     -- end of irec loop --  c     -- end of irec loop --
297        enddo        enddo
298    
299        do irec = nrec_nl*sny+1, ncvarrecs(ivartype)        do irec = nrec_nl*ny+1, ncvarrecs(ivartype)
300  cgg       do iobcs = 1, nobcs  cgg       do iobcs = 1, nobcs
301  cgg       And now back-calculate what iobcs should be.  cgg       And now back-calculate what iobcs should be.
302           iobcs= mod(irec-1,nobcs)+1           iobcs= mod(irec-1,nobcs)+1
# Line 248  cgg       And now back-calculate what io Line 311  cgg       And now back-calculate what io
311           read(cunit) filej           read(cunit) filej
312           read(cunit) filei           read(cunit) filei
313           do k = 1, Nr           do k = 1, Nr
314                irectrue = (irec-1)*nobcs*nr + (iobcs-1)*nr + k
315              cbuffindex = nwetglobal(k,iobcs)              cbuffindex = nwetglobal(k,iobcs)
316              if ( cbuffindex .gt. 0 ) then              if ( cbuffindex .gt. 0 ) then
317                 read(cunit) filencbuffindex                 read(cunit) filencbuffindex
# Line 264  cgg       And now back-calculate what io Line 328  cgg       And now back-calculate what io
328                 endif                 endif
329                 read(cunit) (cbuff(ii), ii=1,cbuffindex)                 read(cunit) (cbuff(ii), ii=1,cbuffindex)
330              endif              endif
331    
332              cbuffindex = 0              cbuffindex = 0
333              do jp = 1,nPy              do jp = 1,nPy
334               do bj = jtlo,jthi               do bj = jtlo,jthi
# Line 273  cgg       And now back-calculate what io Line 338  cgg       And now back-calculate what io
338                    if ( globmskxz(i,bi,ip,bj,jp,k,iobcs) .ne. 0. ) then                    if ( globmskxz(i,bi,ip,bj,jp,k,iobcs) .ne. 0. ) then
339                       cbuffindex = cbuffindex + 1                       cbuffindex = cbuffindex + 1
340                       globfldxz(i,bi,ip,bj,jp,k) = cbuff(cbuffindex)                       globfldxz(i,bi,ip,bj,jp,k) = cbuff(cbuffindex)
341    cph(
342                         globfldtmp2(i,bi,ip,bj,jp) = cbuff(cbuffindex)
343    cph)
344  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO  #ifdef ALLOW_NONDIMENSIONAL_CONTROL_IO
345                       globfldxz(i,bi,ip,bj,jp,k) =                       globfldxz(i,bi,ip,bj,jp,k) =
346       &                    globfldxz(i,bi,ip,bj,jp,k)/       &                    globfldxz(i,bi,ip,bj,jp,k)/
347  # ifdef CTRL_UNPACK_PRECISE  # ifdef CTRL_UNPACK_PRECISE
348       &                    sqrt(weightfldxz(i,bi,ip,bj,jp,k,iobcs))       &                    sqrt(weightfldxz(i,bi,ip,bj,jp,k,iobcs))
# Line 285  cgg       And now back-calculate what io Line 353  cgg       And now back-calculate what io
353                    else                    else
354                       globfldxz(i,bi,ip,bj,jp,k) = 0. _d 0                       globfldxz(i,bi,ip,bj,jp,k) = 0. _d 0
355                    endif                    endif
356    cph(
357                      globfldtmp3(i,bi,ip,bj,jp) =
358         &                 globfldxz(i,bi,ip,bj,jp,k)
359    cph)
360                  enddo                  enddo
361                 enddo                 enddo
362                enddo                enddo
363               enddo               enddo
364              enddo              enddo
365  c  c
366                if ( doPackDiag ) then
367                   write(cunit2,rec=irectrue) globfldtmp2
368                   write(cunit3,rec=irectrue) globfldtmp3
369                endif
370    c
371  c     -- end of k loop --  c     -- end of k loop --
372           enddo           enddo
373                
374           call MDSWRITEFIELD_XZ_GL( fname, ctrlprec, 'RL',           call MDSWRITEFIELD_XZ_GL( fname, ctrlprec, 'RL',
375       &                             Nr, globfldxz, irec,       &                             Nr, globfldxz, irec,
376       &                             optimcycle, mythid)       &                             optimcycle, mythid)
# Line 305  c     -- end of irec loop -- Line 382  c     -- end of irec loop --
382    
383        _END_MASTER( mythid )        _END_MASTER( mythid )
384    
385    #endif
386    
387        return        return
388        end        end
389    
Legend:
Removed from v.1.9  
changed lines
  Added in v.1.15
  ViewVC Help
Powered by ViewVC 1.1.22