Back to home page

MITgcm
 
 

    

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

view on githubraw file Latest commit add29e06 on 2018-01-31 20:35:05 UTC
afb8c08a8f Jean*0001 #include "DIAG_OPTIONS.h"
                0002 
                0003 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0004 CBOP 0
                0005 C     !ROUTINE: DIAGNOSTICS_INTERP_VERT
                0006 
                0007 C     !INTERFACE:
ab01bc8ab2 Jean*0008       SUBROUTINE DIAGNOSTICS_INTERP_VERT(
861a196fd3 Jean*0009      I                        listId, md, ndId, ip, im, lm,
                0010      U                        qtmp1,
21170727e9 Jean*0011      O                        qtmp2,
                0012      I                        undefRL,
861a196fd3 Jean*0013      I                        myTime, myIter, myThid )
afb8c08a8f Jean*0014 
                0015 C     !DESCRIPTION:
                0016 C     Interpolate vertically a diagnostics field before writing to file.
861a196fd3 Jean*0017 C       presently implemented (for Atmospheric fields only):
afb8c08a8f Jean*0018 C         Interpolation (linear in p^kappa) to standard pressure levels
861a196fd3 Jean*0019 C
afb8c08a8f Jean*0020 
                0021 C     !USES:
                0022       IMPLICIT NONE
                0023 #include "SIZE.h"
                0024 #include "EEPARAMS.h"
                0025 #include "PARAMS.h"
                0026 #include "GRID.h"
                0027 #include "DIAGNOSTICS_SIZE.h"
                0028 #include "DIAGNOSTICS.h"
                0029 
861a196fd3 Jean*0030       INTEGER NrMax
49f3c51920 Jean*0031       PARAMETER( NrMax = numLevels )
afb8c08a8f Jean*0032 
                0033 
                0034 C     !INPUT PARAMETERS:
                0035 C     listId  :: Diagnostics list number being written
                0036 C     md      :: field number in the list "listId".
                0037 C     ndId    :: diagnostics  Id number (in available diagnostics list)
                0038 C     ip      :: diagnostics  pointer to storage array
                0039 C     im      :: counter-mate pointer to storage array
861a196fd3 Jean*0040 C     lm      :: index in the averageCycle
afb8c08a8f Jean*0041 C     qtmp1   :: diagnostics field output array
21170727e9 Jean*0042 C     qtmp2   :: temp working array (same size as output array)
                0043 C     undefRL ::
afb8c08a8f Jean*0044 C     myTime  :: current time of simulation (s)
                0045 C     myIter  :: current iteration number
                0046 C     myThid  :: my Thread Id number
861a196fd3 Jean*0047       INTEGER listId, md, ndId, ip, im, lm
                0048       _RL     qtmp1(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
21170727e9 Jean*0049       _RL     qtmp2(1-OLx:sNx+OLx,1-OLy:sNy+OLy,NrMax,nSx,nSy)
                0050       _RL     undefRL
afb8c08a8f Jean*0051       _RL     myTime
                0052       INTEGER myIter, myThid
                0053 CEOP
                0054 
f8e6aa21ed Jean*0055 C     !FUNCTIONS:
                0056 #ifdef ALLOW_FIZHI
                0057       _RL   getcon
                0058       EXTERNAL getcon
                0059 #endif
                0060 
afb8c08a8f Jean*0061 C     !LOCAL VARIABLES:
                0062 C     i,j,k :: loop indices
                0063       INTEGER i, j, k
                0064       INTEGER bi, bj
861a196fd3 Jean*0065       _RL   qtmpsrf(1-OLx:sNx+OLx,1-OLy:sNy+OLy,nSx,nSy)
                0066       INTEGER kLev
                0067       _RL   qprs (sNx,sNy)
                0068       _RL   qinp (sNx,sNy,NrMax)
                0069       _RL   pkz  (sNx,sNy,NrMax)
                0070       _RL   pksrf(sNx,sNy)
21170727e9 Jean*0071       _RL   pk, pkTop
861a196fd3 Jean*0072       _RL   kappa
21170727e9 Jean*0073       INTEGER jpoint1, ipoint1
                0074       INTEGER jpoint2, ipoint2
861a196fd3 Jean*0075       LOGICAL pInc
afb8c08a8f Jean*0076       CHARACTER*(MAX_LEN_MBUF) msgBuf
                0077 
                0078 C---+----1----+----2----+----3----+----4----+----5----+----6----+----7-|--+----|
                0079 
861a196fd3 Jean*0080       IF (fflags(listId)(2:2).EQ.'P') THEN
                0081         pkTop = 0. _d 0
f8e6aa21ed Jean*0082         kappa = atm_kappa
                0083 #ifdef ALLOW_FIZHI
                0084         IF ( useFIZHI ) kappa = getcon('KAPPA')
                0085 #endif
861a196fd3 Jean*0086 
                0087 C--   If nonlinear free surf is active, need averaged pressures
                0088         IF (select_rStar.GT.0) THEN
                0089           CALL DIAGNOSTICS_GET_POINTERS( 'RSURF   ', listId,
                0090      &                                   jpoint1, ipoint1, myThid )
                0091 C-    IF fizhi is being  used, may need to get physics grid pressures
                0092           IF ( useFIZHI .AND.
                0093      &          gdiag(ndId)(10:10) .EQ. 'L') THEN
                0094            CALL DIAGNOSTICS_GET_POINTERS('FIZPRES ', listId,
                0095      &                                   jpoint2, ipoint2, myThid )
                0096           ELSE
                0097            CALL DIAGNOSTICS_GET_POINTERS('RCENTER ', listId,
                0098      &                                   jpoint2, ipoint2, myThid )
                0099           ENDIF
                0100           IF ( ipoint1.EQ.0 .OR. ipoint2.EQ.0 ) THEN
e129400813 Jean*0101             WRITE(msgBuf,'(2A,I6,2A)') 'DIAGNOSTICS_INTERP_VERT: ',
861a196fd3 Jean*0102      &      'fails to interpolate diag.(#', ndId,'): ',flds(md,listId)
afb8c08a8f Jean*0103             CALL PRINT_ERROR( msgBuf , myThid )
                0104             STOP 'ABNORMAL END: S/R DIAGNOSTICS_INTERP_VERT'
861a196fd3 Jean*0105           ENDIF
                0106 C-    averageCycle: move pointer
                0107           ipoint1 = ipoint1 + kdiag(jpoint1)*(lm-1)
                0108           ipoint2 = ipoint2 + kdiag(jpoint2)*(lm-1)
afb8c08a8f Jean*0109 
861a196fd3 Jean*0110           DO bj = myByLo(myThid), myByHi(myThid)
                0111            DO bi = myBxLo(myThid), myBxHi(myThid)
21170727e9 Jean*0112              CALL DIAGNOSTICS_GET_DIAG( 1, undefRL,
861a196fd3 Jean*0113      O                     qtmpsrf(1-OLx,1-OLy,bi,bj),
                0114      I                     jpoint1,0,ipoint1,0, bi,bj,myThid )
                0115 c            WRITE(0,*) 'rSurf:',bi,bj,qtmpsrf(15,15,bi,bj)
21170727e9 Jean*0116              CALL DIAGNOSTICS_GET_DIAG( 0, undefRL,
                0117      O                     qtmp2(1-OLx,1-OLy,1,bi,bj),
861a196fd3 Jean*0118      I                     jpoint2,0,ipoint2,0, bi,bj,myThid )
afb8c08a8f Jean*0119            ENDDO
861a196fd3 Jean*0120           ENDDO
                0121 
                0122         ELSE
                0123 C-    If nonlinear free surf is off, get pressures from rC and rF arrays
                0124 
afb8c08a8f Jean*0125           DO bj = myByLo(myThid), myByHi(myThid)
                0126            DO bi = myBxLo(myThid), myBxHi(myThid)
                0127             DO j = 1-OLy,sNy+OLy
                0128              DO i = 1-OLx,sNx+OLx
861a196fd3 Jean*0129                qtmpsrf(i,j,bi,bj) = Ro_surf(i,j,bi,bj)
afb8c08a8f Jean*0130              ENDDO
                0131             ENDDO
861a196fd3 Jean*0132             DO k = 1,kdiag(ndId)
                0133              DO j = 1-OLy,sNy+OLy
                0134               DO i = 1-OLx,sNx+OLx
afb8c08a8f Jean*0135                qtmp2(i,j,k,bi,bj) = rC(k)
                0136               ENDDO
                0137              ENDDO
                0138             ENDDO
                0139            ENDDO
                0140           ENDDO
861a196fd3 Jean*0141 
                0142 C-    end if nonlinear/linear free-surf
                0143         ENDIF
                0144 
                0145 C--   start loops on tile indices bi,bj:
                0146         DO bj = myByLo(myThid), myByHi(myThid)
                0147          DO bi = myBxLo(myThid), myBxHi(myThid)
                0148 C-    Load p to the kappa into a temporary array
                0149            DO j = 1,sNy
                0150             DO i = 1,sNx
                0151               pksrf(i,j)    = qtmpsrf(i,j,bi,bj)**kappa
                0152             ENDDO
                0153            ENDDO
                0154            IF ( useFIZHI.AND.gdiag(ndId)(10:10).EQ.'L') THEN
                0155             pInc = .TRUE.
                0156             DO k = 1,kdiag(ndId)
                0157              DO j = 1,sNy
                0158               DO i = 1,sNx
                0159                 qinp(i,j,k) = qtmp1(i,j,k,bi,bj)
                0160                 pkz(i,j,k)  = qtmp2(i,j,k,bi,bj)**kappa
afb8c08a8f Jean*0161               ENDDO
                0162              ENDDO
                0163             ENDDO
861a196fd3 Jean*0164            ELSE
                0165             DO k = 1,kdiag(ndId)
                0166              pInc = .TRUE.
                0167              kLev = kdiag(ndId)-k+1
                0168 c            pInc = .FALSE.
                0169 c            kLev = k
                0170              DO j = 1,sNy
                0171               DO i = 1,sNx
                0172                 IF (maskC(i,j,kLev,bi,bj).NE.0.) THEN
                0173                  qinp(i,j,k)= qtmp1(i,j,kLev,bi,bj)
                0174                 ELSE
21170727e9 Jean*0175                  qinp(i,j,k)= undefRL
861a196fd3 Jean*0176                 ENDIF
                0177                 pkz(i,j,k)  = qtmp2(i,j,kLev,bi,bj)**kappa
afb8c08a8f Jean*0178               ENDDO
                0179              ENDDO
                0180             ENDDO
861a196fd3 Jean*0181            ENDIF
                0182 
                0183 C-    Interpolate, level per level, and put interpolated field in qprs:
                0184            DO k = 1,nlevels(listId)
                0185              pk = levs(k,listId)**kappa
                0186              CALL DIAGNOSTICS_INTERP_P2P(
                0187      O                        qprs,
                0188      I                        qinp,pkz,pksrf,pkTop,pk,
21170727e9 Jean*0189      I                        undefRL,pInc,sNx*sNy,kdiag(ndId),myThid )
861a196fd3 Jean*0190 C-    Transfert qprs to qtmp1:
                0191              DO j = 1,sNy
                0192               DO i = 1,sNx
21170727e9 Jean*0193                IF (qprs(i,j).EQ.undefRL) THEN
861a196fd3 Jean*0194                  qtmp1(i,j,k,bi,bj) = 0.
                0195                ELSE
                0196                  qtmp1(i,j,k,bi,bj) =  qprs(i,j)
                0197                ENDIF
                0198               ENDDO
                0199              ENDDO
afb8c08a8f Jean*0200            ENDDO
                0201 
861a196fd3 Jean*0202 C-   end bi,bj loops
                0203          ENDDO
                0204         ENDDO
                0205 
                0206       ENDIF
afb8c08a8f Jean*0207 
                0208       RETURN
                0209       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!