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

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

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

revision 1.21 by gforget, Sat Sep 25 23:04:07 2010 UTC revision 1.22 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 288  c Line 289  c
289    
290        _END_MASTER( mythid )        _END_MASTER( mythid )
291    
292    # else
293    c     == local variables ==
294    
295          integer bi,bj
296          integer ip,jp
297          integer i,j,k
298          integer ii
299          integer il
300          integer irec
301          integer itlo,ithi
302          integer jtlo,jthi
303    
304          integer cbuffindex
305    
306          _RL msk3d(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
307          real*8 msk2d_buf(sNx,sNy,nSx,nSy)
308          real*8 msk2d_buf_glo(Nx,Ny)
309    
310          _RL fld3d(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
311          real*8 fld2d_buf(sNx,sNy,nSx,nSy)
312          real*8 fld2d_buf_glo(Nx,Ny)
313    
314          _RL fld3dDim(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
315          _RL fld3dNodim(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
316    
317    #ifdef CTRL_PACK_PRECISE
318          _RL wei3d(1-Olx:sNx+Olx,1-Oly:sNy+Oly,Nr,nSx,nSy)
319  #endif  #endif
320    
321          real*4 cbuff      ( snx*nsx*npx*sny*nsy*npy )
322    
323          character*(80) weightname
324          _RL delZnorm
325          character*(80) cfile2, cfile3
326    
327    c     == external ==
328    
329          integer  ilnblnk
330          external ilnblnk
331    
332    c     == end of interface ==
333    
334    c-- part 1: preliminary reads and definitions
335    
336    #ifdef CTRL_PACK_PRECISE
337          call active_read_xyz(weighttype, wei3d, 1,
338         &    .FALSE., .FALSE., 0 , mythid, 1)
339    #endif
340    
341          call active_read_xyz(masktype, msk3d, 1,
342         &    .FALSE., .FALSE., 0 , mythid, 1)
343    
344          if ( doPackDiag ) then
345             write(cfile2(1:80),'(80a)') ' '
346             write(cfile3(1:80),'(80a)') ' '
347             il = ilnblnk( fname )
348             if ( lxxadxx ) then
349                write(cfile2(1:80),'(2a)') fname(1:il),'.unpack_ctrl_adim'
350                write(cfile3(1:80),'(2a)') fname(1:il),'.unpack_ctrl_dim'
351             else
352                write(cfile2(1:80),'(2a)') fname(1:il),'.unpack_grad_adim'
353                write(cfile3(1:80),'(2a)') fname(1:il),'.unpack_grad_dim'
354             endif
355          endif
356    
357    c-- part 2: loop over records
358    
359          do irec = 1, ncvarrecs(ivartype)
360    
361    c-- 2.1: array <- buffer <- global buffer <- global file
362    
363    #ifndef ALLOW_ADMTLM
364          _BEGIN_MASTER( mythid )
365            IF ( myProcId .eq. 0 ) THEN
366             read(cunit) filencvarindex(ivartype)
367             if (filencvarindex(ivartype) .NE. ncvarindex(ivartype))
368         &        then
369                print *, 'ctrl_set_unpack_xyz:WARNING: wrong ncvarindex ',
370         &           filencvarindex(ivartype), ncvarindex(ivartype)
371                STOP 'in S/R ctrl_unpack'
372             endif
373             read(cunit) filej
374             read(cunit) filei
375            ENDIF
376          _END_MASTER( mythid )
377          _BARRIER
378    #endif /* ALLOW_ADMTLM */
379    
380          do k = 1, nr
381    
382            CALL MDS_PASS_R8toRL( msk2d_buf, msk3d,
383         &                       1, k, Nr, 0, 0, .FALSE., myThid )
384            CALL BAR2( myThid )
385            CALL GATHER_2D_R8( msk2d_buf_glo, msk2d_buf,
386         &                       Nx,Ny,.FALSE.,.TRUE.,myThid)
387            CALL BAR2( myThid )
388    
389            _BEGIN_MASTER( mythid )
390             cbuffindex = nwetglobal(k)
391            IF ( myProcId .eq. 0 ) THEN
392    
393    #ifndef ALLOW_ADMTLM
394            if ( cbuffindex .gt. 0) then
395              read(cunit) filencbuffindex
396              read(cunit) filek
397              if (filencbuffindex .NE. cbuffindex) then
398                print *, 'WARNING: wrong cbuffindex ',
399         &                 filencbuffindex, cbuffindex
400                STOP 'in S/R ctrl_unpack'
401              endif
402              if (filek .NE. k) then
403                print *, 'WARNING: wrong k ',
404         &                 filek, k
405                STOP 'in S/R ctrl_unpack'
406              endif
407              read(cunit) (cbuff(ii), ii=1,cbuffindex)
408            endif
409    #endif
410    
411            cbuffindex = 0
412            DO j=1,Ny
413              DO i=1,Nx
414                if (msk2d_buf_glo(i,j) .ne. 0. ) then
415                   cbuffindex = cbuffindex + 1
416                   fld2d_buf_glo(i,j) = cbuff(cbuffindex)
417                endif
418              ENDDO
419            ENDDO
420    
421            ENDIF
422            _END_MASTER( mythid )
423            _BARRIER
424    
425            CALL BAR2( myThid )
426            CALL SCATTER_2D_R8( fld2d_buf_glo, fld2d_buf,
427         &                       Nx,Ny,.FALSE.,.TRUE.,myThid)
428            CALL BAR2( myThid )
429            CALL MDS_PASS_R8toRL( fld2d_buf, fld3dNodim,
430         &                       1, k, nr, 0, 0, .TRUE., myThid )
431    
432          enddo !do k = 1, nr
433    
434    c-- 2.2: normalize field if needed
435          DO bj = myByLo(myThid), myByHi(myThid)
436           DO bi = myBxLo(myThid), myBxHi(myThid)
437            DO k=1,Nr
438             if ( doZscalePack ) then
439                delZnorm = (delR(1)/delR(k))**delZexp
440             else
441                delZnorm = 1. _d 0
442             endif
443             DO j=1,sNy
444              DO i=1,sNx
445               if (msk3d(i,j,k,bi,bj).EQ.0. _d 0) then
446                fld3dDim(i,j,k,bi,bj)=0. _d 0
447                fld3dNodim(i,j,k,bi,bj)=0. _d 0
448               else
449    #ifdef ALLOW_ADMTLM
450                nveccount = nveccount + 1
451                fld3dNodim(i,j,k,bi,bj)=phtmpadmtlm(nveccount)
452    #endif          
453    #ifdef ALLOW_SMOOTH_CORREL3D
454                fld3dDim(i,j,k,bi,bj)=fld3dNodim(i,j,k,bi,bj)
455    #else
456    # ifndef ALLOW_NONDIMENSIONAL_CONTROL_IO
457                fld3dDim(i,j,k,bi,bj) = fld3dNodim(i,j,k,bi,bj)
458    # else
459                if (lxxadxx) then
460                   fld3dDim(i,j,k,bi,bj) =
461         &              fld3dNodim(i,j,k,bi,bj) * delZnorm
462    #  ifdef CTRL_PACK_PRECISE
463         &              / sqrt(wei3d(i,j,k,bi,bj))
464    #  else
465         &              / sqrt(weightfld(k,bi,bj))
466    #  endif
467                else
468                   fld3dDim(i,j,k,bi,bj) =
469         &              fld3dNodim(i,j,k,bi,bj) / delZnorm
470    #  ifdef CTRL_PACK_PRECISE
471         &              * sqrt(wei3d(i,j,k,bi,bj))
472    #  else
473         &              * sqrt(weightfld(k,bi,bj))
474    #  endif
475                endif
476    # endif /* ALLOW_NONDIMENSIONAL_CONTROL_IO */
477    #endif /* ALLOW_SMOOTH_CORREL3D */
478               endif
479              ENDDO
480             ENDDO
481            ENDDO
482           ENDDO
483          ENDDO
484    
485    c-- 2.3:
486          if ( doPackDiag ) then
487    c error: twice the same one
488          call WRITE_REC_3D_RL( cfile2, ctrlprec,
489         &        Nr, fld3dNodim, irec, 0, mythid)
490          call WRITE_REC_3D_RL( cfile3, ctrlprec,
491         &        Nr, fld3dDim, irec, 0, mythid)
492          endif
493    
494    c-- 2.4:
495          call WRITE_REC_3D_RL( fname, ctrlprec,
496         &        Nr, fld3dDim, irec, 0, mythid)
497    
498    
499          enddo !do irec = 1, ncvarrecs(ivartype)
500    
501    # endif /* ALLOW_PACKUNPACK_METHOD2 */
502    # endif /* EXCLUDE_CTRL_PACK */
503    
504        return        return
505        end        end
506    
Legend:
Removed from v.1.21  
changed lines
  Added in v.1.22
  ViewVC Help
Powered by ViewVC 1.1.22