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

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

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

revision 1.19 by jmc, Tue Oct 9 00:00:01 2007 UTC revision 1.20 by gforget, Sun Sep 26 02:51:38 2010 UTC
# Line 45  c     == routine arguments == Line 45  c     == routine arguments ==
45        integer mythid        integer mythid
46    
47  #ifndef EXCLUDE_CTRL_PACK  #ifndef EXCLUDE_CTRL_PACK
48    # ifndef ALLOW_PACKUNPACK_METHOD2
49  c     == local variables ==  c     == local variables ==
50    
51        integer bi,bj        integer bi,bj
# Line 260  c     -- end of irec loop -- Line 261  c     -- end of irec loop --
261    
262        _END_MASTER( mythid )        _END_MASTER( mythid )
263    
264    # else
265    c     == local variables ==
266    
267          integer bi,bj
268          integer ip,jp
269          integer i,j,k
270          integer ii
271          integer il
272          integer irec
273          integer itlo,ithi
274          integer jtlo,jthi
275    
276          integer cbuffindex
277    
278          _RL msk3d(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
279          real*8 msk2d_buf(sNx,sNy,nSx,nSy)
280          real*8 msk2d_buf_glo(Nx,Ny)
281    
282          _RL fld3d(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
283          real*8 fld2d_buf(sNx,sNy,nSx,nSy)
284          real*8 fld2d_buf_glo(Nx,Ny)
285    
286          _RL fld3dDim(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
287          _RL fld3dNodim(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
288    
289    #ifdef CTRL_PACK_PRECISE
290          _RL wei3d(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
291    #endif
292    
293          real*4 cbuff      ( snx*nsx*npx*sny*nsy*npy )
294    
295          character*(80) weightname
296          _RL delZnorm
297          character*(80) cfile2, cfile3
298    
299    c     == external ==
300    
301          integer  ilnblnk
302          external ilnblnk
303    
304    c     == end of interface ==
305    
306    c-- part 1: preliminary reads and definitions
307    
308    #ifdef CTRL_PACK_PRECISE
309          call active_read_xyz(weighttype, wei3d, 1,
310         &    .FALSE., .FALSE., 0 , mythid, 1)
311  #endif  #endif
312    
313          call active_read_xyz(masktype, msk3d, 1,
314         &    .FALSE., .FALSE., 0 , mythid, 1)
315    
316          if ( doPackDiag ) then
317             write(cfile2(1:80),'(80a)') ' '
318             write(cfile3(1:80),'(80a)') ' '
319             il = ilnblnk( fname )
320             if ( lxxadxx ) then
321                write(cfile2(1:80),'(2a)') fname(1:il),'.pack_ctrl_adim'
322                write(cfile3(1:80),'(2a)') fname(1:il),'.pack_ctrl_dim'
323             else
324                write(cfile2(1:80),'(2a)') fname(1:il),'.pack_grad_adim'
325                write(cfile3(1:80),'(2a)') fname(1:il),'.pack_grad_dim'
326             endif
327          endif
328    
329    c-- part 2: loop over records
330    
331          do irec = 1, ncvarrecs(ivartype)
332    
333    c-- 2.1:
334          call READ_REC_3D_RL( fname, ctrlprec,
335         &        Nr, fld3dDim, irec, 0, mythid)
336    
337    c-- 2.2: normalize field if needed
338          DO bj = myByLo(myThid), myByHi(myThid)
339           DO bi = myBxLo(myThid), myBxHi(myThid)
340            DO k=1,Nr
341             if ( doZscalePack ) then
342                delZnorm = (delR(1)/delR(k))**delZexp
343             else
344                delZnorm = 1. _d 0
345             endif
346             DO j=1,sNy
347              DO i=1,sNx
348               if (msk3d(i,j,k,bi,bj).EQ.0. _d 0) then
349                fld3dDim(i,j,k,bi,bj)=0. _d 0
350                fld3dNodim(i,j,k,bi,bj)=0. _d 0
351               else
352    #ifdef ALLOW_SMOOTH_CORREL3D
353                fld3dNodim(i,j,k,bi,bj)=fld3dDim(i,j,k,bi,bj)
354    #else
355    # ifndef ALLOW_NONDIMENSIONAL_CONTROL_IO
356                fld3dNodim(i,j,k,bi,bj) = fld3dDim(i,j,k,bi,bj)
357    # else
358                if (lxxadxx) then
359                   fld3dNodim(i,j,k,bi,bj) =
360         &              fld3dDim(i,j,k,bi,bj) / delZnorm
361    #  ifdef CTRL_PACK_PRECISE
362         &              * sqrt(wei3d(i,j,k,bi,bj))
363    #  else
364         &              * sqrt(weightfld(k,bi,bj))
365    #  endif
366                else
367                   fld3dNodim(i,j,k,bi,bj) =
368         &              fld3dDim(i,j,k,bi,bj) * delZnorm
369    #  ifdef CTRL_PACK_PRECISE
370         &              / sqrt(wei3d(i,j,k,bi,bj))
371    #  else
372         &              / sqrt(weightfld(k,bi,bj))
373    #  endif
374                endif
375    # endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
376    #endif /* ALLOW_SMOOTH_CORREL3D */
377               endif
378              ENDDO
379             ENDDO
380            ENDDO
381           ENDDO
382          ENDDO
383    
384    c-- 2.3:
385          if ( doPackDiag ) then
386    c error: twice the same one
387          call WRITE_REC_3D_RL( cfile2, ctrlprec,
388         &        Nr, fld3dNodim, irec, 0, mythid)
389          call WRITE_REC_3D_RL( cfile3, ctrlprec,
390         &        Nr, fld3dDim, irec, 0, mythid)
391          endif
392    
393    c-- 2.4: array -> buffer -> global buffer -> global file
394    
395    #ifndef ALLOW_ADMTLM
396          _BEGIN_MASTER( mythid )
397          IF ( myProcId .eq. 0 ) THEN
398             write(cunit) ncvarindex(ivartype)
399             write(cunit) 1
400             write(cunit) 1
401          ENDIF
402          _END_MASTER( mythid )
403          _BARRIER
404    #endif
405    
406          do k = 1, nr
407    
408            CALL MDS_PASS_R8toRL( fld2d_buf, fld3dNodim,
409         &                       1, k, Nr, 0, 0, .FALSE., myThid )
410            CALL BAR2( myThid )
411            CALL GATHER_2D_R8( fld2d_buf_glo, fld2d_buf,
412         &                       Nx,Ny,.FALSE.,.TRUE.,myThid)
413            CALL BAR2( myThid )
414    
415            CALL MDS_PASS_R8toRL( msk2d_buf, msk3d,
416         &                       1, k, Nr, 0, 0, .FALSE., myThid )
417            CALL BAR2( myThid )
418            CALL GATHER_2D_R8( msk2d_buf_glo, msk2d_buf,
419         &                       Nx,Ny,.FALSE.,.TRUE.,myThid)
420            CALL BAR2( myThid )
421    
422            _BEGIN_MASTER( mythid )
423            cbuffindex = 0
424            IF ( myProcId .eq. 0 ) THEN
425    
426            DO j=1,Ny
427              DO i=1,Nx
428                if (msk2d_buf_glo(i,j) .ne. 0. ) then
429                   cbuffindex = cbuffindex + 1
430                   cbuff(cbuffindex) = fld2d_buf_glo(i,j)
431    #ifdef ALLOW_ADMTLM
432                   nveccount = nveccount + 1
433                   phtmpadmtlm(nveccount) = cbuff(cbuffindex)
434    #endif
435                endif
436              ENDDO
437            ENDDO
438    
439    #ifndef ALLOW_ADMTLM
440            if ( cbuffindex .gt. 0) then
441              write(cunit) cbuffindex
442              write(cunit) k
443              write(cunit) (cbuff(ii), ii=1,cbuffindex)
444            endif
445    #endif
446    
447            ENDIF
448            _END_MASTER( mythid )
449            _BARRIER
450    
451          enddo
452          enddo
453    
454    # endif /* ALLOW_PACKUNPACK_METHOD2 */
455    # endif /* EXCLUDE_CTRL_PACK */
456    
457        return        return
458        end        end
   
Legend:
Removed from v.1.19  
changed lines
  Added in v.1.20
  ViewVC Help
Powered by ViewVC 1.1.22