pkg/diagnostics/diagnostics_sum_levels.F

4b158a6b20 Jean*0001 #include "DIAG_OPTIONS.h"
                0002
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP 0
                0005 C     !ROUTINE: DIAGNOSTICS_SUM_LEVELS
                0006
                0007 C     !INTERFACE:
                0008       SUBROUTINE DIAGNOSTICS_SUM_LEVELS(
                0009      I                        listId, md, ndId, ip, im, lm,
                0010      U                        fld3d,
                0011      I                        undef,
                0012      I                        myTime, myIter, myThid )
                0013
                0014 C     !DESCRIPTION:
                0015 C     Cumulate selected levels from a multi-level diagnostics field
                0016 C       before writing to file this level integrated output
                0017 C     (e.g., can be used to integrate vertically an Nr field).
                0018
                0019 C     !USES:
                0020       IMPLICIT NONE
                0021 #include "SIZE.h"
                0022 #include "EEPARAMS.h"
                0023 #include "PARAMS.h"
                0024 #include "GRID.h"
                0025 #include "DIAGNOSTICS_SIZE.h"
                0026 #include "DIAGNOSTICS.h"
                0027
                0028       INTEGER NrMax
                0029       PARAMETER( NrMax = numLevels )
                0030
                0031 C     !INPUT PARAMETERS:
                0032 C     listId  :: Diagnostics list number being written
                0033 C     md      :: field number in the list "listId".
                0034 C     ndId    :: diagnostics  Id number (in available diagnostics list)
                0035 C     ip      :: diagnostics  pointer to storage array
                0036 C     im      :: counter-mate pointer to storage array
                0037 C     lm      :: index in the averageCycle
                0038 C     fld3d   :: diagnostics field output array
                0039 C     undef   ::
                0040 C     myTime  :: current time of simulation (s)
                0041 C     myIter  :: current iteration number
                0042 C     myThid  :: my Thread Id number
                0043       INTEGER listId, md, ndId, ip, im, lm
                0044       _RL     fld3d(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
                0045       _RL     undef
                0046       _RL     myTime
                0047       INTEGER myIter, myThid
                0048 CEOP
                0049
                0050 C     !FUNCTIONS:
                0051
                0052 C     !LOCAL VARIABLES:
                0053 C     i,j,k :: loop indices
                0054       INTEGER i, j, k
                0055       INTEGER bi, bj
                0056       INTEGER kLev
                0057       _RL     tmpFld(1-OLx:sNx+OLx,1-OLy:sNy+OLy)
                0058       _RL     tmpFac, hFacLoc
                0059 c     CHARACTER*(MAX_LEN_MBUF) msgBuf
                0060       CHARACTER*(10) gcode
6094e476c8 Jean*0061       LOGICAL wFac
4b158a6b20 Jean*0062
                0063 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0064
6094e476c8 Jean*0065       IF ( fflags(listId)(2:2).EQ.'I' ) THEN
4b158a6b20 Jean*0066
                0067         gcode = gdiag(ndId)(1:10)
6094e476c8 Jean*0068         wFac = jdiag(md,listId).LT.0
4b158a6b20 Jean*0069
                0070 C--   start loops on tile indices bi,bj:
                0071         DO bj = myByLo(myThid), myByHi(myThid)
                0072          DO bi = myBxLo(myThid), myBxHi(myThid)
                0073
                0074           DO j = 1-OLy,sNy+OLy
                0075             DO i = 1-OLx,sNx+OLx
                0076               tmpFld(i,j) = 0. _d 0
                0077             ENDDO
                0078           ENDDO
                0079
                0080           IF ( gcode(3:3).EQ.' ' ) THEN
                0081 C--   Cumulate levels directly:
                0082
                0083              DO k = 1,nlevels(listId)
                0084               kLev = NINT(levs(k,listId))
1d99daeaf6 Oliv*0085               DO j = 1,sNy+1
                0086                DO i = 1,sNx+1
4b158a6b20 Jean*0087                 tmpFld(i,j) = tmpFld(i,j) + fld3d(i,j,kLev,bi,bj)
                0088                ENDDO
                0089               ENDDO
                0090              ENDDO
                0091              DO j = 1-OLy,sNy+OLy
                0092               DO i = 1-OLx,sNx+OLx
                0093                 fld3d(i,j,1,bi,bj) = tmpFld(i,j)
                0094               ENDDO
                0095              ENDDO
                0096
6094e476c8 Jean*0097           ELSEIF ( gcode(3:3).EQ.'r' .OR.
                0098      &            (gcode(3:3).EQ.'R' .AND. wFac) ) THEN
4b158a6b20 Jean*0099 C--   Cumulate the level-thickness product:
                0100
                0101              DO k = 1,nlevels(listId)
                0102               kLev = NINT(levs(k,listId))
                0103               IF ( gcode(9:9).EQ.'L' ) THEN
                0104                 tmpFac = drC(kLev)
                0105               ELSE
                0106                 tmpFac = drF(kLev)
                0107               ENDIF
1d99daeaf6 Oliv*0108               DO j = 1,sNy+1
                0109                DO i = 1,sNx+1
4b158a6b20 Jean*0110                 tmpFld(i,j) = tmpFld(i,j)
                0111      &                      + tmpFac*fld3d(i,j,kLev,bi,bj)
                0112                ENDDO
                0113               ENDDO
                0114              ENDDO
                0115              DO j = 1-OLy,sNy+OLy
                0116               DO i = 1-OLx,sNx+OLx
                0117                 fld3d(i,j,1,bi,bj) = tmpFld(i,j)
                0118               ENDDO
                0119              ENDDO
                0120
                0121           ELSEIF ( gcode(3:3).EQ.'R' ) THEN
                0122 C--   Cumulate the level-thickness & hFac product:
                0123
                0124              IF ( gcode(2:2).EQ.'M' ) THEN
                0125                DO k = 1,nlevels(listId)
                0126                kLev = NINT(levs(k,listId))
                0127                IF ( gcode(9:9).EQ.'L' ) THEN
                0128                  tmpFac = drC(kLev)
                0129                ELSE
                0130                  tmpFac = drF(kLev)
                0131                ENDIF
1d99daeaf6 Oliv*0132                DO j = 1,sNy+1
                0133                 DO i = 1,sNx+1
4b158a6b20 Jean*0134                  tmpFld(i,j) = tmpFld(i,j)
                0135      &                       + tmpFac*fld3d(i,j,kLev,bi,bj)
                0136      &                               *hFacC(i,j,kLev,bi,bj)
                0137                 ENDDO
                0138                ENDDO
                0139               ENDDO
                0140              ELSEIF ( gcode(2:2).EQ.'U' ) THEN
                0141               DO k = 1,nlevels(listId)
                0142                kLev = NINT(levs(k,listId))
                0143                IF ( gcode(9:9).EQ.'L' ) THEN
                0144                  tmpFac = drC(kLev)
                0145                ELSE
                0146                  tmpFac = drF(kLev)
                0147                ENDIF
1d99daeaf6 Oliv*0148                DO j = 1,sNy+1
                0149                 DO i = 1,sNx+1
4b158a6b20 Jean*0150                  tmpFld(i,j) = tmpFld(i,j)
                0151      &                       + tmpFac*fld3d(i,j,kLev,bi,bj)
                0152      &                               *hFacW(i,j,kLev,bi,bj)
                0153                 ENDDO
                0154                ENDDO
                0155               ENDDO
                0156              ELSEIF ( gcode(2:2).EQ.'V' ) THEN
                0157               DO k = 1,nlevels(listId)
                0158                kLev = NINT(levs(k,listId))
                0159                IF ( gcode(9:9).EQ.'L' ) THEN
                0160                  tmpFac = drC(kLev)
                0161                ELSE
                0162                  tmpFac = drF(kLev)
                0163                ENDIF
1d99daeaf6 Oliv*0164                DO j = 1,sNy+1
                0165                 DO i = 1,sNx+1
4b158a6b20 Jean*0166                  tmpFld(i,j) = tmpFld(i,j)
                0167      &                       + tmpFac*fld3d(i,j,kLev,bi,bj)
                0168      &                               *hFacS(i,j,kLev,bi,bj)
                0169                 ENDDO
                0170                ENDDO
                0171               ENDDO
                0172              ELSEIF ( gcode(2:2).EQ.'Z' ) THEN
                0173               DO k = 1,nlevels(listId)
                0174                kLev = NINT(levs(k,listId))
                0175                IF ( gcode(9:9).EQ.'L' ) THEN
                0176                  tmpFac = drC(kLev)
                0177                ELSE
                0178                  tmpFac = drF(kLev)
                0179                ENDIF
1d99daeaf6 Oliv*0180                DO j = 1,sNy+1
                0181                 DO i = 1,sNx+1
4b158a6b20 Jean*0182                  hFacLoc = MIN(
                0183      &                          hFacW( i, j, kLev,bi,bj),
                0184      &                          hFacW( i,j-1,kLev,bi,bj),
                0185      &                          hFacS( i, j, kLev,bi,bj),
                0186      &                          hFacS(i-1,j, kLev,bi,bj)
                0187      &                        )
                0188                  tmpFld(i,j) = tmpFld(i,j)
                0189      &                       + tmpFac*fld3d(i,j,kLev,bi,bj)
                0190      &                               *hFacLoc
                0191                 ENDDO
                0192                ENDDO
                0193               ENDDO
                0194              ELSE
                0195                STOP 'DIAGNOSTICS_SUM_LEVELS: invalid gcode(2)'
                0196              ENDIF
                0197              DO j = 1-OLy,sNy+OLy
                0198               DO i = 1-OLx,sNx+OLx
                0199                 fld3d(i,j,1,bi,bj) = tmpFld(i,j)
                0200               ENDDO
                0201              ENDDO
                0202
                0203           ELSE
                0204             STOP 'DIAGNOSTICS_SUM_LEVELS: Bad gcode(3) option'
                0205           ENDIF
                0206
                0207 C-   end bi,bj loops
                0208          ENDDO
                0209         ENDDO
                0210
                0211       ENDIF
                0212
                0213       RETURN
                0214       END