Back to home page

MITgcm
 
 

    

File indexing completed on 2018-03-02 18:38:55 UTC

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
088ca933b6 Andr*0001 #include "DIAG_OPTIONS.h"
                0002 
                0003 CBOP
                0004 C     !ROUTINE: DIAG_VEGTILE_FILL
                0005 C     !INTERFACE:
6ff64991c4 Jean*0006       SUBROUTINE DIAG_VEGTILE_FILL(
                0007      &                field,indx,chfr,ib,numpts,npeice,
                0008      &                check, chardiag, kLev, nLevs, bi, bj, myThid )
088ca933b6 Andr*0009 C     !DESCRIPTION:
                0010 C***********************************************************************
                0011 C Increment the diagnostics array with a vegetation tile space field
                0012 C***********************************************************************
                0013 C     !USES:
                0014       IMPLICIT NONE
                0015 
                0016 C     == Global variables ===
                0017 #include "EEPARAMS.h"
                0018 #include "SIZE.h"
                0019 #include "DIAGNOSTICS_SIZE.h"
                0020 #include "DIAGNOSTICS.h"
                0021 
                0022 C     !INPUT PARAMETERS:
                0023 C***********************************************************************
6ff64991c4 Jean*0024 C   field    :: array to be mapped to grid space [ib,levs] and added to qdiag
                0025 C   indx     :: array of horizontal indices of grid points to convert to
                0026 C               tile space[numpts]
                0027 C   chfr     :: fractional area covered by the tile [ib]
                0028 C   ib       :: inner dimension of source array and number of points in
                0029 C               array a that need to be pasted
                0030 C   numpts   :: total number of points which were stripped
                0031 C   npeice   :: the current strip number to be filled
                0032 C   check    :: logical to check for undefined values
                0033 C   chardiag :: Character expression for diag to fill
                0034 C   kLev     :: Integer flag for vertical levels:
                0035 C                > 0 (any integer): which single level to increment
088ca933b6 Andr*0036 C                0,-1 to increment "nLevs" levels in qdiag:
6ff64991c4 Jean*0037 C                  0 : fill-in in the same order as the input array
                0038 C                 -1 : fill-in in reverse order.
                0039 C   nLevs    :: indicates Number of levels of the input field array
                0040 C   bi       :: X-direction tile number
                0041 C   bj       :: Y-direction tile number
                0042 C   myThid   :: my thread Id number
088ca933b6 Andr*0043 C***********************************************************************
                0044       CHARACTER*8 chardiag
                0045       INTEGER kLev, nLevs, bi, bj
                0046       INTEGER myThid
6ff64991c4 Jean*0047       INTEGER ib,numpts,npeice
                0048       INTEGER indx(numpts)
088ca933b6 Andr*0049       _RL field(ib,nlevs), chfr(ib)
6ff64991c4 Jean*0050       LOGICAL check
088ca933b6 Andr*0051 CEOP
                0052 
                0053 C     !LOCAL VARIABLES:
                0054 C ===============
e129400813 Jean*0055       INTEGER m, n
088ca933b6 Andr*0056       INTEGER ndiagnum, ipointer
                0057       INTEGER k, kFirst, kLast
                0058       INTEGER kd, kd0, ksgn, kStore
                0059       CHARACTER*(MAX_LEN_MBUF) msgBuf
6ff64991c4 Jean*0060       INTEGER offset, Lena
                0061       INTEGER ivt, ij, i
f8e6aa21ed Jean*0062       _RL undef
ad4d037731 Jean*0063       INTEGER iSp, ndId, j,l
                0064       INTEGER region2fill(0:nRegions)
                0065       _RL     scaleFact
                0066       _RL     gridField(sNx*sNy,nlevs), gridFrac(sNx*sNy)
0d603ffc5e Jean*0067 #ifndef REAL4_IS_SLOW
2d87091177 Jean*0068       _RS     dummyRS(1)
0d603ffc5e Jean*0069 #endif
088ca933b6 Andr*0070 
f8e6aa21ed Jean*0071 #ifdef ALLOW_FIZHI
                0072       _RL   getcon
                0073       EXTERNAL getcon
                0074 #endif
                0075 
088ca933b6 Andr*0076 C Run through list of active diagnostics to make sure
                0077 C we are trying to fill a valid diagnostic
                0078 
f8e6aa21ed Jean*0079       undef = UNSET_RL
6ff64991c4 Jean*0080 #ifdef ALLOW_FIZHI
                0081       IF ( check ) undef = getcon('UNDEF')
                0082 #endif
088ca933b6 Andr*0083       ndiagnum = 0
                0084       ipointer = 0
                0085       DO n=1,nlists
                0086        DO m=1,nActive(n)
3ae5f90260 Jean*0087         IF ( chardiag.EQ.flds(m,n) .AND. idiag(m,n).GT.0 ) THEN
b38beaf3c1 Jean*0088          ndiagnum = ABS(jdiag(m,n))
3ae5f90260 Jean*0089          ipointer = idiag(m,n)
                0090          IF ( ndiagnum.NE.0 .AND. ndiag(ipointer,1,1).GE.0 ) THEN
                0091 C--   do the filling: start here:
088ca933b6 Andr*0092 
6ff64991c4 Jean*0093           IF ( (ABS(kLev).LE.1) .AND. (npeice.EQ.1) ) THEN
3ae5f90260 Jean*0094 C Increment the counter for the diagnostic
6ff64991c4 Jean*0095             ndiag(ipointer,bi,bj) = ndiag(ipointer,bi,bj) + 1
                0096           ENDIF
088ca933b6 Andr*0097 
6ff64991c4 Jean*0098           offset = ib*(npeice-1)
                0099           Lena   = MIN(ib,numpts-offset)
088ca933b6 Andr*0100 
                0101 C-      Which part of field to add : k = 3rd index,
                0102 C         and do the loop >> do k=kFirst,kLast <<
6ff64991c4 Jean*0103           IF (kLev.LE.0) THEN
                0104            kFirst = 1
                0105            kLast  = nLevs
                0106           ELSEIF ( nLevs.EQ.1 ) THEN
                0107            kFirst = 1
                0108            kLast  = 1
                0109           ELSEIF ( kLev.LE.nLevs ) THEN
                0110            kFirst = kLev
                0111            kLast  = kLev
                0112           ELSE
                0113            STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL kLev > nLevs > 0'
                0114           ENDIF
e129400813 Jean*0115 C-      Which part of qdiag to update: kd = 3rd index,
088ca933b6 Andr*0116 C         and do the loop >> do k=kFirst,kLast ; kd = kd0 + k*ksgn <<
6ff64991c4 Jean*0117           IF ( kLev.EQ.-1 ) THEN
                0118            ksgn = -1
                0119            kd0 = ipointer + nLevs
                0120           ELSEIF ( kLev.EQ.0 ) THEN
                0121            ksgn = 1
                0122            kd0 = ipointer - 1
                0123           ELSE
                0124            ksgn = 0
                0125            kd0 = ipointer + kLev - 1
                0126           ENDIF
088ca933b6 Andr*0127 
                0128 C-      Check for consistency with Nb of levels reserved in storage array
6ff64991c4 Jean*0129           kStore = kd0 + MAX(ksgn*kFirst,ksgn*kLast) - ipointer + 1
                0130           IF ( kStore.GT.kdiag(ndiagnum) ) THEN
                0131            _BEGIN_MASTER(myThid)
                0132            WRITE(msgBuf,'(2A,I4,A)') 'DIAGNOSTICS_FILL: ',
                0133      &      'exceed Nb of levels(=',kdiag(ndiagnum),' ) reserved '
                0134            CALL PRINT_ERROR( msgBuf , myThid )
                0135            WRITE(msgBuf,'(2A,I6,2A)') 'DIAGNOSTICS_FILL: ',
                0136      &      'for Diagnostics #', ndiagnum, ' : ', chardiag
                0137            CALL PRINT_ERROR( msgBuf , myThid )
                0138            WRITE(msgBuf,'(2A,2I4,I3)') 'calling DIAGNOSTICS_FILL ',
                0139      &      'with kLev,nLevs=', kLev,nLevs
                0140            CALL PRINT_ERROR( msgBuf , myThid )
                0141            WRITE(msgBuf,'(2A,I6,A)') 'DIAGNOSTICS_FILL: ',
                0142      &      '==> trying to store up to ', kStore, ' levels'
                0143            CALL PRINT_ERROR( msgBuf , myThid )
                0144            STOP 'ABNORMAL END: S/R DIAGNOSTICS_FILL'
                0145            _END_MASTER(myThid)
                0146           ENDIF
088ca933b6 Andr*0147 
6ff64991c4 Jean*0148           DO k = kFirst,kLast
                0149            kd = kd0 + ksgn*k
                0150            IF ( check ) THEN
                0151             DO ivt = 1,Lena
                0152              ij = indx(ivt+offset) - 1
                0153              j = 1 + INT(ij/sNx)
                0154              i = 1 + MOD(ij,sNx)
                0155              IF ( field(ivt,k).EQ.undef ) THEN
                0156               qdiag(i,j,kd,bi,bj) = undef
                0157              ELSEIF ( qdiag(i,j,kd,bi,bj).NE.undef ) THEN
                0158               qdiag(i,j,kd,bi,bj) = qdiag(i,j,kd,bi,bj)
                0159      &                            + field(ivt,k)*chfr(ivt)
                0160              ENDIF
                0161             ENDDO
                0162            ELSE
                0163             DO ivt = 1,Lena
                0164               ij = indx(ivt+offset) - 1
                0165               j = 1 + INT(ij/sNx)
                0166               i = 1 + MOD(ij,sNx)
                0167               qdiag(i,j,kd,bi,bj) = qdiag(i,j,kd,bi,bj)
                0168      &                            + field(ivt,k)*chfr(ivt)
                0169             ENDDO
                0170            ENDIF
                0171           ENDDO
088ca933b6 Andr*0172 
3ae5f90260 Jean*0173 C--   do the filling: ends here.
                0174          ENDIF
                0175         ENDIF
                0176        ENDDO
                0177       ENDDO
088ca933b6 Andr*0178 
ad4d037731 Jean*0179 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0180 C--   Global/Regional Statistics :
                0181       scaleFact = 1. _d 0
                0182 
                0183 C Run through list of active statistics-diagnostics to make sure
                0184 C we are trying to compute & fill a valid diagnostic
                0185 
                0186       DO n=1,diagSt_nbLists
                0187        DO m=1,diagSt_nbActv(n)
                0188         IF ( chardiag.EQ.diagSt_Flds(m,n) .AND. iSdiag(m,n).GT.0 ) THEN
                0189          iSp = iSdiag(m,n)
                0190          IF ( qSdiag(0,0,iSp,bi,bj).GE.0. ) THEN
                0191            ndId = jSdiag(m,n)
                0192 C-    Find list of regions to fill:
                0193            DO j=0,nRegions
                0194             region2fill(j) = diagSt_region(j,n)
                0195            ENDDO
                0196 C-    if this diagnostics appears in several lists (with same freq)
                0197 C     then add regions from other lists
                0198            DO l=1,diagSt_nbLists
                0199             DO k=1,diagSt_nbActv(l)
                0200              IF ( iSdiag(k,l).EQ.-iSp ) THEN
                0201               DO j=0,nRegions
                0202                region2fill(j) = MAX(region2fill(j),diagSt_region(j,l))
                0203               ENDDO
                0204              ENDIF
                0205             ENDDO
                0206            ENDDO
                0207 
                0208 C-      Which part of field to add : k = 3rd index,
                0209 C         and do the loop >> do k=kFirst,kLast <<
6ff64991c4 Jean*0210            IF (kLev.LE.0) THEN
                0211             kFirst = 1
                0212             kLast  = nLevs
                0213            ELSE
                0214             kFirst = 1
                0215             kLast  = 1
                0216            ENDIF
ad4d037731 Jean*0217 
                0218 C-    Fill local array with grid-space field after conversion.
6ff64991c4 Jean*0219            offset = ib*(npeice-1)
                0220            Lena    = MIN(ib,numpts-offset)
ad4d037731 Jean*0221 
6ff64991c4 Jean*0222            DO ij = 1,sNx*sNy
                0223              gridFrac(ij)= 0.
                0224            ENDDO
                0225            DO ivt = 1,Lena
                0226              ij = indx(ivt+offset)
                0227              gridFrac(ij)=gridFrac(ij)+chfr(ivt)
                0228            ENDDO
ad4d037731 Jean*0229 
6ff64991c4 Jean*0230            DO k = kFirst,kLast
                0231             DO ij = 1,sNx*sNy
                0232              gridField(ij,k)= 0.
                0233             ENDDO
                0234             IF ( check ) THEN
                0235              DO ivt = 1,Lena
                0236               ij = indx(ivt+offset)
                0237               IF ( field(ivt,k).EQ.undef ) THEN
                0238                gridField(ij,k) = undef
                0239               ELSEIF ( gridFrac(ij).GT.0. _d 0 ) THEN
                0240                gridField(ij,k) = gridField(ij,k)
                0241      &                         + field(ivt,k)*chfr(ivt)/gridFrac(ij)
                0242               ENDIF
                0243              ENDDO
                0244             ELSE
                0245              DO ivt = 1,Lena
                0246               ij = indx(ivt+offset)
                0247               IF ( gridFrac(ij).GT.0. _d 0 ) THEN
                0248                gridField(ij,k) = gridField(ij,k)
                0249      &                         + field(ivt,k)*chfr(ivt)/gridFrac(ij)
                0250               ENDIF
                0251              ENDDO
                0252             ENDIF
                0253            ENDDO
ad4d037731 Jean*0254 
                0255 C-    diagnostics is valid and Active: Now do the filling
                0256            CALL DIAGSTATS_FILL(
2d87091177 Jean*0257      I              gridField, gridFrac,
                0258 #ifndef REAL4_IS_SLOW
                0259      I               dummyRS, dummyRS,
                0260 #endif
                0261      I              scaleFact, 1, 0, 1,
ad4d037731 Jean*0262      I              ndId, iSp, region2fill, kLev, nLevs,
                0263      I              3, bi, bj, myThid )
                0264          ENDIF
                0265         ENDIF
                0266        ENDDO
                0267       ENDDO
                0268 
e129400813 Jean*0269       RETURN
088ca933b6 Andr*0270       END
[ Source navigation ] [ Diff markup ] [ Identifier search ] [ general search ]

This page was automatically generated from https://github.com/MITgcm/MITgcm by the 2.2.1-MITgcm-0.1 LXR engine.

The LXR team
Valid CSS 2.1! Valid HTML 4.01!