pkg/fizhi/CtoA.F

a456aa407c Andr*0001 #include "FIZHI_OPTIONS.h"
28c2441183 Jean*0002        subroutine CtoA(myThid,fieldin1,fieldin2,mask1,mask2,idim1,idim2,
                0003      .  jdim1,jdim2,numlevs,Nsx,Nsy,im1,im2,jm1,jm2,fieldout1,fieldout2)
e337e4ca8c Andr*0004 c----------------------------------------------------------------------
                0005 c  Subroutine CtoA - Routine to map a velocity component quantity
                0006 c         from the C-Grid to the A-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 c-grid to move to a-grid (1st component)
                0013 c         fieldin2    Field on c-grid to move to a-grid (2nd component)
                0014 c         mask1       Topography [0,1] mask - 1 to indicate above ground
                0015 c         mask2       Topography [0,1] mask - 1 to indicate above ground
28c2441183 Jean*0016 c         idim1,idim2,jdim1,jdim2   Indeces in x and y for computations
e337e4ca8c Andr*0017 c         numlevs     Number of vertical levels
                0018 c         Nsx, Nsy
28c2441183 Jean*0019 c         im1,im2,jm1,jm2   Span of fields in x and y
e337e4ca8c Andr*0020 c
                0021 c Output: fieldout1   Field mapped to A-Grid (1st component)
                0022 c         fieldout2   Field mapped to A-Grid (2nd component)
                0023 c
                0024 c Call: exchange on c-grid
                0025 c-----------------------------------------------------------------------
                0026        implicit none
                0027 #include "EEPARAMS.h"
                0028
                0029        integer myThid, numlevs
28c2441183 Jean*0030        integer idim1, idim2, jdim1, jdim2, im1, im2, jm1, jm2
e337e4ca8c Andr*0031        integer Nsx, Nsy
28c2441183 Jean*0032        _RS mask1(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
                0033        _RS mask2(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
                0034        _RL fieldin1(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
                0035        _RL fieldin2(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
                0036        _RL fieldout1(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
                0037        _RL fieldout2(idim1:idim2,jdim1:jdim2,numlevs,Nsx,Nsy)
e337e4ca8c Andr*0038
                0039        integer i, j, L, bi, bj
                0040        logical withSigns
                0041        data withSigns/.TRUE./
28c2441183 Jean*0042        _RL tmpfld1(idim1:idim2,jdim1:jdim2)
                0043        _RL tmpfld2(idim1:idim2,jdim1:jdim2)
e337e4ca8c Andr*0044
                0045 c Call the c-grid exchange routine to fill in the halo regions
                0046        call exch_uv_xyz_RL(fieldin1,fieldin2,withSigns,myThid)
                0047
                0048 c Now take average
                0049        do bj = myByLo(myThid), myByHi(myThid)
                0050        do bi = myBxLo(myThid), myBxHi(myThid)
                0051
                0052         do L = 1,numlevs
f98d2ec0f4 Andr*0053          do j = jdim1,jdim2
28c2441183 Jean*0054           do i = idim1,idim2
                0055            tmpfld1(i,j) = fieldin1(i,j,L,bi,bj)*mask1(i,j,L,bi,bj)
                0056            tmpfld2(i,j) = fieldin2(i,j,L,bi,bj)*mask2(i,j,L,bi,bj)
                0057           enddo
                0058          enddo
                0059          do j = jm1,jm2
                0060          do i = im1,im2
e337e4ca8c Andr*0061           if( (mask1(i,j,L,bi,bj).ne.0.) .or.
                0062      .                               (mask1(i+1,j,L,bi,bj).ne.0.) ) then
28c2441183 Jean*0063 c          fieldout1(i,j,L,bi,bj) =
                0064 c    .        ( fieldin1(i,j,L,bi,bj)*mask1(i,j,L,bi,bj) +
                0065 c    .          fieldin1(i+1,j,L,bi,bj)*mask1(i+1,j,L,bi,bj) ) /
                0066 c    .            ( mask1(i,j,L,bi,bj) + mask1(i+1,j,L,bi,bj) )
e337e4ca8c Andr*0067            fieldout1(i,j,L,bi,bj) =
28c2441183 Jean*0068      .            ( tmpfld1(i,j) + tmpfld1(i+1,j) ) /
e337e4ca8c Andr*0069      .            ( mask1(i,j,L,bi,bj) + mask1(i+1,j,L,bi,bj) )
                0070           else
                0071            fieldout1(i,j,L,bi,bj) = 0.
                0072           endif
                0073           if( (mask2(i,j,L,bi,bj).ne.0.) .or.
                0074      .                               (mask2(i,j+1,L,bi,bj).ne.0.) ) then
28c2441183 Jean*0075 c          fieldout2(i,j,L,bi,bj) =
                0076 c    .        ( fieldin2(i,j,L,bi,bj)*mask2(i,j,L,bi,bj) +
                0077 c    .          fieldin2(i,j+1,L,bi,bj)*mask2(i,j+1,L,bi,bj) ) /
                0078 c    .            ( mask2(i,j,L,bi,bj) + mask2(i,j+1,L,bi,bj) )
e337e4ca8c Andr*0079            fieldout2(i,j,L,bi,bj) =
28c2441183 Jean*0080      .            ( tmpfld2(i,j) + tmpfld2(i,j+1) ) /
e337e4ca8c Andr*0081      .            ( mask2(i,j,L,bi,bj) + mask2(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