pkg/fizhi/AtoC.F

a456aa407c Andr*0001 #include "FIZHI_OPTIONS.h"
28c2441183 Jean*0002        subroutine AtoC(myThid,fieldin1,fieldin2,mask,idim1,idim2,
                0003      .  jdim1,jdim2,numlevs,Nsx,Nsy,im1,im2,jm1,jm2,fieldout1,fieldout2)
e337e4ca8c Andr*0004 c----------------------------------------------------------------------
                0005 c  Subroutine AtoC - Routine to map a velocity component quantity
                0006 c         from the A-Grid to the C-Grid.
                0007 c         This includes doing an exchange to fill the halo region, and
                0008 c         then a linear average with the appropriate topography mask.
                0009 c         Also: Set up "bi, bj loop" here.
                0010 c
                0011 c  Input: myThid
                0012 c         fieldin1    Field on a-grid to move to a-grid (1st component)
                0013 c         fieldin2    Field on a-grid to move to a-grid (2nd component)
                0014 c         mask        Topography [0,1] mask - 1 to indicate above ground
28c2441183 Jean*0015 c         idim1,idim2,jdim1,jdim2   Indeces in x and y for computations
e337e4ca8c Andr*0016 c         numlevs     Number of vertical levels
                0017 c         Nsx, Nsy
28c2441183 Jean*0018 c         im1,im2,jm1,jm2   Span of fields in x and y
e337e4ca8c Andr*0019 c
                0020 c Output: fieldout1   Field mapped to C-Grid (1st component)
                0021 c         fieldout2   Field mapped to C-Grid (2nd component)
                0022 c
c40f81fe30 Jean*0023 c Call:   exch_uv_agrid_3d_RL - exchange on a-grid
e337e4ca8c Andr*0024 c-----------------------------------------------------------------------
                0025        implicit none
                0026 #include "EEPARAMS.h"
c40f81fe30 Jean*0027
e337e4ca8c Andr*0028        integer myThid, numlevs
                0029        integer Nsx, Nsy
28c2441183 Jean*0030        integer idim1, idim2, jdim1, jdim2, im1, im2, jm1, jm2
                0031        _RS mask(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
                0032        _RL fieldin1(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
                0033        _RL fieldin2(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
                0034        _RL fieldout1(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
                0035        _RL fieldout2(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
e337e4ca8c Andr*0036
                0037        integer i, j, L, bi, bj
28c2441183 Jean*0038        _RL tmpfld1(idim1:idim2,jdim1:jdim2)
                0039        _RL tmpfld2(idim1:idim2,jdim1:jdim2)
e337e4ca8c Andr*0040
                0041 c Call the exchange routine to fill in the halo regions
c40f81fe30 Jean*0042        CALL EXCH_UV_AGRID_3D_RL(
                0043      U                           fieldin1, fieldin2,
                0044      I                           .TRUE., numlevs, myThid )
e337e4ca8c Andr*0045
                0046 c Now take average
                0047        do bj = myByLo(myThid), myByHi(myThid)
                0048        do bi = myBxLo(myThid), myBxHi(myThid)
                0049
                0050         do L = 1,numlevs
f98d2ec0f4 Andr*0051          do j = jdim1,jdim2
28c2441183 Jean*0052           do i = idim1,idim2
                0053            tmpfld1(i,j) = fieldin1(i,j,L,bi,bj)*mask(i,j,L,bi,bj)
                0054            tmpfld2(i,j) = fieldin2(i,j,L,bi,bj)*mask(i,j,L,bi,bj)
                0055           enddo
                0056          enddo
                0057          do j = jm1,jm2
                0058          do i = im1,im2
                0059 c        do j = jm2,jm1,-1
                0060 c        do i = im2,im1,-1
e337e4ca8c Andr*0061           if( (mask(i-1,j,L,bi,bj).ne.0.) .or.
                0062      .                                  (mask(i,j,L,bi,bj).ne.0.) ) then
28c2441183 Jean*0063 c          fieldout1(i,j,L,bi,bj) =
                0064 c    .       ( fieldin1(i-1,j,L,bi,bj)*mask(i-1,j,L,bi,bj) +
                0065 c    .         fieldin1(i,j,L,bi,bj)*mask(i,j,L,bi,bj) ) /
                0066 c    .           ( mask(i-1,j,L,bi,bj) + mask(i,j,L,bi,bj) )
e337e4ca8c Andr*0067            fieldout1(i,j,L,bi,bj) =
28c2441183 Jean*0068      .           ( tmpfld1(i-1,j) + tmpfld1(i,j) ) /
e337e4ca8c Andr*0069      .           ( mask(i-1,j,L,bi,bj) + mask(i,j,L,bi,bj) )
                0070           else
                0071            fieldout1(i,j,L,bi,bj) = 0.
                0072           endif
                0073           if( (mask(i,j-1,L,bi,bj).ne.0.) .or.
                0074      .                                  (mask(i,j,L,bi,bj).ne.0.) ) then
28c2441183 Jean*0075 c          fieldout2(i,j,L,bi,bj) =
                0076 c    .       ( fieldin2(i,j-1,L,bi,bj)*mask(i,j-1,L,bi,bj) +
                0077 c    .         fieldin2(i,j,L,bi,bj)*mask(i,j,L,bi,bj) ) /
                0078 c    .           ( mask(i,j,L,bi,bj) + mask(i,j-1,L,bi,bj) )
e337e4ca8c Andr*0079            fieldout2(i,j,L,bi,bj) =
28c2441183 Jean*0080      .           ( tmpfld2(i,j-1) + tmpfld2(i,j) ) /
e337e4ca8c Andr*0081      .           ( mask(i,j,L,bi,bj) + mask(i,j-1,L,bi,bj) )
                0082           else
                0083            fieldout2(i,j,L,bi,bj) = 0.
                0084           endif
                0085          enddo
                0086          enddo
                0087         enddo
                0088
                0089        enddo
                0090        enddo
                0091
                0092        return
                0093        end